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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (show annotations)
Sat Dec 25 14:49:54 2004 UTC (9 years, 3 months ago) by rstrandh
Branch: MAIN
Changes since 1.15: +3 -3 lines
Simplified the syntax protocol according to suggestions from Teemu Kalvas.
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 :initarg :syntax :accessor syntax)))
36
37 (defmethod initialize-instance :after ((pane climacs-pane) &rest args)
38 (declare (ignore args))
39 (with-slots (buffer point syntax) pane
40 (when (null point)
41 (setf point (make-instance 'standard-right-sticky-mark
42 :buffer buffer)))
43 (setf syntax (make-instance 'texinfo-syntax :pane pane))))
44
45 (define-application-frame climacs ()
46 ((win :reader win))
47 (:panes
48 (win (make-pane 'climacs-pane
49 :width 600 :height 400
50 :name 'win
51 :display-function 'display-win))
52 (int :interactor :width 600 :height 50))
53 (:layouts
54 (default
55 (vertically ()
56 (scrolling (:width 600 :height 400) win)
57 int)))
58 (:top-level (climacs-top-level)))
59
60 (defun climacs ()
61 "Starts up a climacs session"
62 (let ((frame (make-application-frame 'climacs)))
63 (run-frame-top-level frame)))
64
65 (defun display-win (frame pane)
66 "The display function used by the climacs application frame."
67 (declare (ignore frame))
68 (redisplay-pane pane))
69
70 (defun find-gestures (gestures start-table)
71 (loop with table = (find-command-table start-table)
72 for (gesture . rest) on gestures
73 for item = (find-keystroke-item gesture table :errorp nil)
74 while item
75 do (if (eq (command-menu-item-type item) :command)
76 (return (if (null rest) item nil))
77 (setf table (command-menu-item-value item)))
78 finally (return item)))
79
80 (defparameter *current-gesture* nil)
81
82 (defun climacs-top-level (frame &key
83 command-parser command-unparser
84 partial-command-parser prompt)
85 (declare (ignore command-parser command-unparser partial-command-parser prompt))
86 (setf (slot-value frame 'win) (find-pane-named frame 'win))
87 (let ((*standard-output* (frame-standard-output frame))
88 (*standard-input* (frame-standard-input frame))
89 (*print-pretty* nil))
90 (redisplay-frame-panes frame :force-p t)
91 (loop with gestures = '()
92 do (setf *current-gesture* (read-gesture :stream *standard-input*))
93 (when (or (characterp *current-gesture*)
94 (and (typep *current-gesture* 'keyboard-event)
95 (keyboard-event-character *current-gesture*)))
96 (setf gestures (nconc gestures (list *current-gesture*)))
97 (let ((item (find-gestures gestures 'global-climacs-table)))
98 (cond ((not item)
99 (beep) (setf gestures '()))
100 ((eq (command-menu-item-type item) :command)
101 (handler-case
102 (funcall (command-menu-item-value item))
103 (error (condition)
104 (beep)
105 (format *error-output* "~a~%" condition)))
106 (setf gestures '()))
107 (t nil))))
108 (redisplay-frame-panes frame :force-p t))))
109
110 (define-command com-quit ()
111 (frame-exit *application-frame*))
112
113 (define-command com-self-insert ()
114 (unless (constituentp *current-gesture*)
115 (possibly-expand-abbrev (point (win *application-frame*))))
116 (insert-object (point (win *application-frame*)) *current-gesture*))
117
118 (define-command com-backward-object ()
119 (decf (offset (point (win *application-frame*)))))
120
121 (define-command com-forward-object ()
122 (incf (offset (point (win *application-frame*)))))
123
124 (define-command com-beginning-of-line ()
125 (beginning-of-line (point (win *application-frame*))))
126
127 (define-command com-end-of-line ()
128 (end-of-line (point (win *application-frame*))))
129
130 (define-command com-delete-object ()
131 (delete-range (point (win *application-frame*))))
132
133 (define-command com-previous-line ()
134 (previous-line (point (win *application-frame*))))
135
136 (define-command com-next-line ()
137 (next-line (point (win *application-frame*))))
138
139 (define-command com-open-line ()
140 (open-line (point (win *application-frame*))))
141
142 (define-command com-kill-line ()
143 (kill-line (point (win *application-frame*))))
144
145 (define-command com-forward-word ()
146 (forward-word (point (win *application-frame*))))
147
148 (define-command com-backward-word ()
149 (backward-word (point (win *application-frame*))))
150
151 (define-command com-toggle-layout ()
152 (setf (frame-current-layout *application-frame*)
153 (if (eq (frame-current-layout *application-frame*) 'default)
154 'with-interactor
155 'default)))
156
157 (define-command com-extended-command ()
158 (accept 'command :prompt "Extended Command"))
159
160 (defclass weird () ()
161 (:documentation "An open ended class."))
162
163 (define-command com-insert-weird-stuff ()
164 (insert-object (point (win *application-frame*)) (make-instance 'weird)))
165
166 (define-command com-insert-reversed-string ()
167 (insert-sequence (point (win *application-frame*))
168 (reverse (accept 'string))))
169
170 (define-presentation-type completable-pathname ()
171 :inherit-from 'pathname)
172
173 (defun filename-completer (so-far mode)
174 (flet ((remove-trail (s)
175 (subseq s 0 (let ((pos (position #\/ s :from-end t)))
176 (if pos (1+ pos) 0)))))
177 (let* ((directory-prefix
178 (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
179 ""
180 (namestring #+sbcl (car (directory ".")) #+cmu (ext:default-directory))))
181 (full-so-far (concatenate 'string directory-prefix so-far))
182 (pathnames
183 (loop with length = (length full-so-far)
184 for path in (directory (concatenate 'string
185 (remove-trail so-far)
186 "*.*"))
187 when (let ((mismatch (mismatch (namestring path) full-so-far)))
188 (or (null mismatch) (= mismatch length)))
189 collect path))
190 (strings (mapcar #'namestring pathnames))
191 (first-string (car strings))
192 (length-common-prefix nil)
193 (completed-string nil)
194 (full-completed-string nil))
195 (unless (null pathnames)
196 (setf length-common-prefix
197 (loop with length = (length first-string)
198 for string in (cdr strings)
199 do (setf length (min length (or (mismatch string first-string) length)))
200 finally (return length))))
201 (unless (null pathnames)
202 (setf completed-string
203 (subseq first-string (length directory-prefix)
204 (if (null (cdr pathnames)) nil length-common-prefix)))
205 (setf full-completed-string
206 (concatenate 'string directory-prefix completed-string)))
207 (case mode
208 ((:complete-limited :complete-maximal)
209 (cond ((null pathnames)
210 (values so-far nil nil 0 nil))
211 ((null (cdr pathnames))
212 (values completed-string t (car pathnames) 1 nil))
213 (t
214 (values completed-string nil nil (length pathnames) nil))))
215 (:complete
216 (cond ((null pathnames)
217 (values so-far nil nil 0 nil))
218 ((null (cdr pathnames))
219 (values completed-string t (car pathnames) 1 nil))
220 ((find full-completed-string strings :test #'string-equal)
221 (let ((pos (position full-completed-string strings :test #'string-equal)))
222 (values completed-string
223 t (elt pathnames pos) (length pathnames) nil)))
224 (t
225 (values completed-string nil nil (length pathnames) nil))))
226 (:possibilities
227 (values nil nil nil (length pathnames)
228 (loop with length = (length directory-prefix)
229 for name in pathnames
230 collect (list (subseq (namestring name) length nil)
231 name))))))))
232
233 (define-presentation-method accept
234 ((type completable-pathname) stream (view textual-view) &key)
235 (multiple-value-bind (pathname success string)
236 (complete-input stream
237 #'filename-completer
238 :partial-completers '(#\Space)
239 :allow-any-input t)
240 (declare (ignore success))
241 (or pathname string)))
242
243 (define-command com-find-file ()
244 (let ((filename (accept 'completable-pathname
245 :prompt "Find File")))
246 (with-slots (buffer point syntax) (win *application-frame*)
247 (setf buffer (make-instance 'climacs-buffer)
248 point (make-instance 'standard-right-sticky-mark :buffer buffer)
249 syntax (make-instance 'texinfo-syntax :pane (win *application-frame*))
250 (filename buffer) filename)
251 (with-open-file (stream filename :direction :input)
252 (input-from-stream stream buffer 0))
253 (beginning-of-buffer point))))
254
255 (define-command com-save-buffer ()
256 (let ((filename (or (filename (buffer (win *application-frame*)))
257 (accept 'completable-pathname
258 :prompt "Save Buffer to File")))
259 (buffer (buffer (win *application-frame*))))
260 (with-open-file (stream filename :direction :output :if-exists :supersede)
261 (output-to-stream stream buffer 0 (size buffer)))))
262
263 (define-command com-beginning-of-buffer ()
264 (beginning-of-buffer (point (win *application-frame*))))
265
266 (define-command com-end-of-buffer ()
267 (end-of-buffer (point (win *application-frame*))))
268
269 (define-command com-browse-url ()
270 (accept 'url :prompt "Browse URL"))
271
272 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
273 ;;;
274 ;;; Global command table
275
276 (make-command-table 'global-climacs-table :errorp nil)
277
278 (defun global-set-key (gesture command)
279 (add-command-to-command-table command 'global-climacs-table
280 :keystroke gesture :errorp nil))
281
282 (loop for code from (char-code #\space) to (char-code #\~)
283 do (global-set-key (code-char code) 'com-self-insert))
284
285 (global-set-key #\newline 'com-self-insert)
286 (global-set-key #\tab 'com-self-insert)
287 (global-set-key '(#\f :control) 'com-forward-object)
288 (global-set-key '(#\b :control) 'com-backward-object)
289 (global-set-key '(#\a :control) 'com-beginning-of-line)
290 (global-set-key '(#\e :control) 'com-end-of-line)
291 (global-set-key '(#\d :control) 'com-delete-object)
292 (global-set-key '(#\p :control) 'com-previous-line)
293 (global-set-key '(#\n :control) 'com-next-line)
294 (global-set-key '(#\o :control) 'com-open-line)
295 (global-set-key '(#\k :control) 'com-kill-line)
296 (global-set-key '(#\f :meta) 'com-forward-word)
297 (global-set-key '(#\b :meta) 'com-backward-word)
298 (global-set-key '(#\x :meta) 'com-extended-command)
299 (global-set-key '(#\a :meta) 'com-insert-weird-stuff)
300 (global-set-key '(#\c :meta) 'com-insert-reversed-string)
301 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
302 (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
303 (global-set-key '(#\u :meta) 'com-browse-url)
304
305 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
306 ;;;
307 ;;; C-x command table
308
309 (make-command-table 'c-x-climacs-table :errorp nil)
310
311 (add-menu-item-to-command-table 'global-climacs-table "C-x"
312 :menu 'c-x-climacs-table
313 :keystroke '(#\x :control))
314
315 (defun c-x-set-key (gesture command)
316 (add-command-to-command-table command 'c-x-climacs-table
317 :keystroke gesture :errorp nil))
318
319 ;;; for some reason, C-c does not seem to arrive as far as CLIM.
320 (c-x-set-key '(#\q :control) 'com-quit)
321 (c-x-set-key '(#\f :control) 'com-find-file)
322 (c-x-set-key '(#\s :control) 'com-save-buffer)

  ViewVC Help
Powered by ViewVC 1.1.5