/[climacs]/climacs/gui.lisp
ViewVC logotype

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Thu Dec 23 18:49:32 2004 UTC (9 years, 3 months ago) by rstrandh
Branch: MAIN
Changes since 1.10: +3 -58 lines
First steps toward a decent redisplay function.

We introduce a protocol class `syntax' used to specialize methods of
the redisplay functions.

We also introduce a class `basic-syntax', a subclass of `syntax' that
can redisplay basic text.  Currently, the redisplay method on
basic-syntax is not terribly smart, as it displays the entire buffer.

Each pane that displays a buffer also contains a syntax used to
determine the way the buffer is to be rendered in that pane.

Currently, the implementation is ahead of the specification with
respect to this syntax abstraction.  That will not be the case for
very long, though.
1 ;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
2
3 ;;; (c) copyright 2004 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2004 by
6 ;;; Elliott Johnson (ejohnson@fasl.info)
7
8 ;;; This library is free software; you can redistribute it and/or
9 ;;; modify it under the terms of the GNU Library General Public
10 ;;; License as published by the Free Software Foundation; either
11 ;;; version 2 of the License, or (at your option) any later version.
12 ;;;
13 ;;; This library is distributed in the hope that it will be useful,
14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;;; Library General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU Library General Public
19 ;;; License along with this library; if not, write to the
20 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;;; Boston, MA 02111-1307 USA.
22
23 ;;; GUI for the Climacs editor.
24
25 (in-package :climacs-gui)
26
27 (defclass filename-mixin ()
28 ((filename :initform nil :accessor filename)))
29
30 (defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin) ())
31
32 (defclass climacs-pane (application-pane)
33 ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer)
34 (point :initform nil :initarg :point :reader point)
35 (syntax :initform (make-instance 'basic-syntax) :initarg :syntax :accessor syntax)))
36
37 (defmethod initialize-instance :after ((pane climacs-pane) &rest args)
38 (declare (ignore args))
39 (with-slots (buffer point) pane
40 (when (null point)
41 (setf point (make-instance 'standard-right-sticky-mark
42 :buffer buffer)))))
43
44 (define-application-frame climacs ()
45 ((win :reader win))
46 (:panes
47 (win (make-pane 'climacs-pane
48 :width 600 :height 400
49 :name 'win
50 :display-function 'display-win))
51 (int :interactor :width 600 :height 50))
52 (:layouts
53 (default
54 (vertically ()
55 (scrolling (:width 600 :height 400) win)
56 int)))
57 (:top-level (climacs-top-level)))
58
59 (defun climacs ()
60 "Starts up a climacs session"
61 (let ((frame (make-application-frame 'climacs)))
62 (run-frame-top-level frame)))
63
64 (defun display-win (frame pane)
65 "The display function used by the climacs application frame."
66 (declare (ignore frame))
67 (redisplay-with-syntax pane (syntax pane)))
68
69 (defun find-gestures (gestures start-table)
70 (loop with table = (find-command-table start-table)
71 for (gesture . rest) on gestures
72 for item = (find-keystroke-item gesture table :errorp nil)
73 while item
74 do (if (eq (command-menu-item-type item) :command)
75 (return (if (null rest) item nil))
76 (setf table (command-menu-item-value item)))
77 finally (return item)))
78
79 (defparameter *current-gesture* nil)
80
81 (defun climacs-top-level (frame &key
82 command-parser command-unparser
83 partial-command-parser prompt)
84 (declare (ignore command-parser command-unparser partial-command-parser prompt))
85 (setf (slot-value frame 'win) (find-pane-named frame 'win))
86 (let ((*standard-output* (frame-standard-output frame))
87 (*standard-input* (frame-standard-input frame))
88 (*print-pretty* nil))
89 (redisplay-frame-panes frame :force-p t)
90 (loop with gestures = '()
91 do (setf *current-gesture* (read-gesture :stream *standard-input*))
92 (when (or (characterp *current-gesture*)
93 (and (typep *current-gesture* 'keyboard-event)
94 (keyboard-event-character *current-gesture*)))
95 (setf gestures (nconc gestures (list *current-gesture*)))
96 (let ((item (find-gestures gestures 'global-climacs-table)))
97 (cond ((not item)
98 (beep) (setf gestures '()))
99 ((eq (command-menu-item-type item) :command)
100 (handler-case
101 (funcall (command-menu-item-value item))
102 (error (condition)
103 (beep)
104 (format *error-output* "~a~%" condition)))
105 (setf gestures '()))
106 (t nil))))
107 (redisplay-frame-panes frame :force-p t))))
108
109 (define-command com-quit ()
110 (frame-exit *application-frame*))
111
112 (define-command com-self-insert ()
113 (unless (constituentp *current-gesture*)
114 (possibly-expand-abbrev (point (win *application-frame*))))
115 (insert-object (point (win *application-frame*)) *current-gesture*))
116
117 (define-command com-backward-object ()
118 (decf (offset (point (win *application-frame*)))))
119
120 (define-command com-forward-object ()
121 (incf (offset (point (win *application-frame*)))))
122
123 (define-command com-beginning-of-line ()
124 (beginning-of-line (point (win *application-frame*))))
125
126 (define-command com-end-of-line ()
127 (end-of-line (point (win *application-frame*))))
128
129 (define-command com-delete-object ()
130 (delete-range (point (win *application-frame*))))
131
132 (define-command com-previous-line ()
133 (previous-line (point (win *application-frame*))))
134
135 (define-command com-next-line ()
136 (next-line (point (win *application-frame*))))
137
138 (define-command com-open-line ()
139 (open-line (point (win *application-frame*))))
140
141 (define-command com-kill-line ()
142 (kill-line (point (win *application-frame*))))
143
144 (define-command com-forward-word ()
145 (forward-word (point (win *application-frame*))))
146
147 (define-command com-backward-word ()
148 (backward-word (point (win *application-frame*))))
149
150 (define-command com-toggle-layout ()
151 (setf (frame-current-layout *application-frame*)
152 (if (eq (frame-current-layout *application-frame*) 'default)
153 'with-interactor
154 'default)))
155
156 (define-command com-extended-command ()
157 (accept 'command :prompt "Extended Command"))
158
159 (defclass weird () ()
160 (:documentation "An open ended class."))
161
162 (define-command com-insert-weird-stuff ()
163 (insert-object (point (win *application-frame*)) (make-instance 'weird)))
164
165
166 (define-presentation-type completable-pathname ()
167 :inherit-from 'pathname)
168
169 (defun filename-completer (so-far mode)
170 (flet ((remove-trail (s)
171 (subseq s 0 (let ((pos (position #\/ s :from-end t)))
172 (if pos (1+ pos) 0)))))
173 (let* ((directory-prefix
174 (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
175 ""
176 (namestring #+sbcl (car (directory ".")) #+cmu (ext:default-directory))))
177 (full-so-far (concatenate 'string directory-prefix so-far))
178 (pathnames
179 (loop with length = (length full-so-far)
180 for path in (directory (concatenate 'string
181 (remove-trail so-far)
182 "*.*"))
183 when (let ((mismatch (mismatch (namestring path) full-so-far)))
184 (or (null mismatch) (= mismatch length)))
185 collect path))
186 (strings (mapcar #'namestring pathnames))
187 (first-string (car strings))
188 (length-common-prefix nil)
189 (completed-string nil)
190 (full-completed-string nil))
191 (unless (null pathnames)
192 (setf length-common-prefix
193 (loop with length = (length first-string)
194 for string in (cdr strings)
195 do (setf length (min length (or (mismatch string first-string) length)))
196 finally (return length))))
197 (unless (null pathnames)
198 (setf completed-string
199 (subseq first-string (length directory-prefix)
200 (if (null (cdr pathnames)) nil length-common-prefix)))
201 (setf full-completed-string
202 (concatenate 'string directory-prefix completed-string)))
203 (case mode
204 ((:complete-limited :complete-maximal)
205 (cond ((null pathnames)
206 (values so-far nil nil 0 nil))
207 ((null (cdr pathnames))
208 (values completed-string t (car pathnames) 1 nil))
209 (t
210 (values completed-string nil nil (length pathnames) nil))))
211 (:complete
212 (cond ((null pathnames)
213 (values so-far nil nil 0 nil))
214 ((null (cdr pathnames))
215 (values completed-string t (car pathnames) 1 nil))
216 ((find full-completed-string strings :test #'string-equal)
217 (let ((pos (position full-completed-string strings :test #'string-equal)))
218 (values completed-string
219 t (elt pathnames pos) (length pathnames) nil)))
220 (t
221 (values completed-string nil nil (length pathnames) nil))))
222 (:possibilities
223 (values nil nil nil (length pathnames)
224 (loop with length = (length directory-prefix)
225 for name in pathnames
226 collect (list (subseq (namestring name) length nil)
227 name))))))))
228
229 (define-presentation-method accept
230 ((type completable-pathname) stream (view textual-view) &key)
231 (multiple-value-bind (pathname success string)
232 (complete-input stream
233 #'filename-completer
234 :partial-completers '(#\Space)
235 :allow-any-input t)
236 (declare (ignore success))
237 (or pathname string)))
238
239 (define-command com-find-file ()
240 (let ((filename (accept 'completable-pathname
241 :prompt "Find File"))
242 (buffer (make-instance 'climacs-buffer)))
243 (setf (buffer (win *application-frame*)) buffer
244 (filename (buffer (win *application-frame*))) filename)
245 (with-open-file (stream filename :direction :input)
246 (input-from-stream stream buffer 0))
247 (setf (slot-value (win *application-frame*) 'point)
248 (make-instance 'standard-right-sticky-mark :buffer buffer))))
249
250 (define-command com-save-buffer ()
251 (let ((filename (or (filename (buffer (win *application-frame*)))
252 (accept 'completable-pathname
253 :prompt "Save Buffer to File")))
254 (buffer (buffer (win *application-frame*))))
255 (with-open-file (stream filename :direction :output :if-exists :supersede)
256 (output-to-stream stream buffer 0 (size buffer)))))
257
258 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
259 ;;;
260 ;;; Global command table
261
262 (make-command-table 'global-climacs-table :errorp nil)
263
264 (defun global-set-key (gesture command)
265 (add-command-to-command-table command 'global-climacs-table
266 :keystroke gesture :errorp nil))
267
268 (loop for code from (char-code #\space) to (char-code #\~)
269 do (global-set-key (code-char code) 'com-self-insert))
270
271 (global-set-key #\newline 'com-self-insert)
272 (global-set-key #\tab 'com-self-insert)
273 (global-set-key '(#\f :control) 'com-forward-object)
274 (global-set-key '(#\b :control) 'com-backward-object)
275 (global-set-key '(#\a :control) 'com-beginning-of-line)
276 (global-set-key '(#\e :control) 'com-end-of-line)
277 (global-set-key '(#\d :control) 'com-delete-object)
278 (global-set-key '(#\p :control) 'com-previous-line)
279 (global-set-key '(#\n :control) 'com-next-line)
280 (global-set-key '(#\o :control) 'com-open-line)
281 (global-set-key '(#\k :control) 'com-kill-line)
282 (global-set-key '(#\f :meta) 'com-forward-word)
283 (global-set-key '(#\b :meta) 'com-backward-word)
284 (global-set-key '(#\x :meta) 'com-extended-command)
285 (global-set-key '(#\a :meta) 'com-insert-weird-stuff)
286
287 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
288 ;;;
289 ;;; C-x command table
290
291 (make-command-table 'c-x-climacs-table :errorp nil)
292
293 (add-menu-item-to-command-table 'global-climacs-table "C-x"
294 :menu 'c-x-climacs-table
295 :keystroke '(#\x :control))
296
297 ;;; for some reason, C-c does not seem to arrive as far as CLIM.
298
299 (add-command-to-command-table 'com-quit 'c-x-climacs-table
300 :keystroke '(#\q :control))
301
302 (add-command-to-command-table 'com-find-file 'c-x-climacs-table
303 :keystroke '(#\f :control))
304
305 (add-command-to-command-table 'com-save-buffer 'c-x-climacs-table
306 :keystroke '(#\s :control))
307
308
309

  ViewVC Help
Powered by ViewVC 1.1.5