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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (show annotations)
Wed Dec 29 05:55:26 2004 UTC (9 years, 3 months ago) by ejohnson
Branch: MAIN
Changes since 1.26: +450 -1893 lines
An error on my part.  Sorry about that.
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 ((name :initform "*scratch*" :accessor name)
32 (modified :initform nil :accessor modified-p)))
33
34 (defclass climacs-pane (application-pane)
35 ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer)
36 (point :initform nil :initarg :point :reader point)
37 (syntax :initarg :syntax :accessor syntax)
38 (mark :initform nil :initarg :mark :reader mark)))
39
40 (defmethod initialize-instance :after ((pane climacs-pane) &rest args)
41 (declare (ignore args))
42 (with-slots (buffer point syntax mark) pane
43 (when (null point)
44 (setf point (make-instance 'standard-right-sticky-mark
45 :buffer buffer)))
46 (when (null mark)
47 (setf mark (make-instance 'standard-right-sticky-mark
48 :buffer buffer)))
49 (setf syntax (make-instance 'texinfo-syntax :pane pane))))
50
51 (define-application-frame climacs ()
52 ((win :reader win))
53 (:panes
54 (win (make-pane 'climacs-pane
55 :width 900 :height 400
56 :name 'win
57 :incremental-redisplay t
58 :display-function 'display-win))
59 (info :application
60 :width 900 :height 20 :max-height 20
61 :name 'info :background +light-gray+
62 :scroll-bars nil
63 :incremental-redisplay t
64 :display-function 'display-info)
65 (int :application :width 900 :height 20 :max-height 20
66 :scroll-bars nil))
67 (:layouts
68 (default
69 (vertically (:scroll-bars nil)
70 (scrolling (:width 900 :height 400) win)
71 info
72 int)))
73 (:top-level (climacs-top-level)))
74
75 (defun climacs ()
76 "Starts up a climacs session"
77 (let ((frame (make-application-frame 'climacs)))
78 (run-frame-top-level frame)))
79
80 (defun display-info (frame pane)
81 (let* ((win (win frame))
82 (buf (buffer win))
83 (name-info (format nil " ~a ~a"
84 (if (modified-p buf) "**" "--")
85 (name buf))))
86 (princ name-info pane)))
87
88 (defun display-win (frame pane)
89 "The display function used by the climacs application frame."
90 (declare (ignore frame))
91 (redisplay-pane pane))
92
93 (defun find-gestures (gestures start-table)
94 (loop with table = (find-command-table start-table)
95 for (gesture . rest) on gestures
96 for item = (find-keystroke-item gesture table :errorp nil)
97 while item
98 do (if (eq (command-menu-item-type item) :command)
99 (return (if (null rest) item nil))
100 (setf table (command-menu-item-value item)))
101 finally (return item)))
102
103 (defvar *kill-ring* (initialize-kill-ring 7))
104 (defparameter *current-gesture* nil)
105
106 (defun climacs-top-level (frame &key
107 command-parser command-unparser
108 partial-command-parser prompt)
109 (declare (ignore command-parser command-unparser partial-command-parser prompt))
110 (setf (slot-value frame 'win) (find-pane-named frame 'win))
111 ;; (let ((*standard-output* (frame-standard-output frame))
112 ;; (*standard-input* (frame-standard-input frame))
113 (let ((*standard-output* (find-pane-named frame 'win))
114 (*standard-input* (find-pane-named frame 'int))
115 (*print-pretty* nil)
116 (*abort-gestures* nil))
117 (redisplay-frame-panes frame :force-p t)
118 (loop with gestures = '()
119 do (setf *current-gesture* (read-gesture :stream *standard-input*))
120 (when (or (characterp *current-gesture*)
121 (and (typep *current-gesture* 'keyboard-event)
122 (or (keyboard-event-character *current-gesture*)
123 (not (member (keyboard-event-key-name
124 *current-gesture*)
125 '(:control-left :control-right
126 :shift-left :shift-right
127 :meta-left :meta-right
128 :super-left :super-right
129 :hyper-left :hyper-right
130 :shift-lock :caps-lock))))))
131 (setf gestures (nconc gestures (list *current-gesture*)))
132 (let ((item (find-gestures gestures 'global-climacs-table)))
133 (cond ((not item)
134 (beep) (setf gestures '()))
135 ((eq (command-menu-item-type item) :command)
136 (handler-case
137 (funcall (command-menu-item-value item))
138 (error (condition)
139 (beep)
140 (format *error-output* "~a~%" condition)))
141 (setf gestures '()))
142 (t nil))))
143 (redisplay-frame-panes frame))))
144
145 (define-command (com-quit :name "Quit" :command-table climacs) ()
146 (frame-exit *application-frame*))
147
148 (define-command com-self-insert ()
149 (unless (constituentp *current-gesture*)
150 (possibly-expand-abbrev (point (win *application-frame*))))
151 (insert-object (point (win *application-frame*)) *current-gesture*)
152 (setf (modified-p (buffer (win *application-frame*))) t))
153
154 (define-command com-backward-object ()
155 (decf (offset (point (win *application-frame*)))))
156
157 (define-command com-forward-object ()
158 (incf (offset (point (win *application-frame*)))))
159
160 (define-command com-beginning-of-line ()
161 (beginning-of-line (point (win *application-frame*))))
162
163 (define-command com-end-of-line ()
164 (end-of-line (point (win *application-frame*))))
165
166 (define-command com-delete-object ()
167 (delete-range (point (win *application-frame*)))
168 (setf (modified-p (buffer (win *application-frame*))) t))
169
170 (define-command com-backward-delete-object ()
171 (delete-range (point (win *application-frame*)) -1)
172 (setf (modified-p (buffer (win *application-frame*))) t))
173
174 (define-command com-previous-line ()
175 (previous-line (point (win *application-frame*))))
176
177 (define-command com-next-line ()
178 (next-line (point (win *application-frame*))))
179
180 (define-command com-open-line ()
181 (open-line (point (win *application-frame*)))
182 (setf (modified-p (buffer (win *application-frame*))) t))
183
184 (define-command com-kill-line ()
185 (kill-line (point (win *application-frame*)))
186 (setf (modified-p (buffer (win *application-frame*))) t))
187
188 (define-command com-forward-word ()
189 (forward-word (point (win *application-frame*))))
190
191 (define-command com-backward-word ()
192 (backward-word (point (win *application-frame*))))
193
194 (define-command com-toggle-layout ()
195 (setf (frame-current-layout *application-frame*)
196 (if (eq (frame-current-layout *application-frame*) 'default)
197 'with-interactor
198 'default)))
199
200 (define-command com-extended-command ()
201 (let ((item (accept 'command :prompt "Extended Command")))
202 (window-clear *standard-input*)
203 (execute-frame-command *application-frame* item)))
204
205 (defclass weird () ()
206 (:documentation "An open ended class."))
207
208 (define-command com-insert-weird-stuff ()
209 (insert-object (point (win *application-frame*)) (make-instance 'weird))
210 (setf (modified-p (buffer (win *application-frame*))) t))
211
212 (define-command com-insert-reversed-string ()
213 (insert-sequence (point (win *application-frame*))
214 (reverse (accept 'string)))
215 (setf (modified-p (buffer (win *application-frame*))) t))
216
217 (define-presentation-type completable-pathname ()
218 :inherit-from 'pathname)
219
220 (defun filename-completer (so-far mode)
221 (flet ((remove-trail (s)
222 (subseq s 0 (let ((pos (position #\/ s :from-end t)))
223 (if pos (1+ pos) 0)))))
224 (let* ((directory-prefix
225 (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/))
226 ""
227 (namestring #+sbcl (car (directory ".")) #+cmu (ext:default-directory))))
228 (full-so-far (concatenate 'string directory-prefix so-far))
229 (pathnames
230 (loop with length = (length full-so-far)
231 for path in (directory (concatenate 'string
232 (remove-trail so-far)
233 "*.*"))
234 when (let ((mismatch (mismatch (namestring path) full-so-far)))
235 (or (null mismatch) (= mismatch length)))
236 collect path))
237 (strings (mapcar #'namestring pathnames))
238 (first-string (car strings))
239 (length-common-prefix nil)
240 (completed-string nil)
241 (full-completed-string nil))
242 (unless (null pathnames)
243 (setf length-common-prefix
244 (loop with length = (length first-string)
245 for string in (cdr strings)
246 do (setf length (min length (or (mismatch string first-string) length)))
247 finally (return length))))
248 (unless (null pathnames)
249 (setf completed-string
250 (subseq first-string (length directory-prefix)
251 (if (null (cdr pathnames)) nil length-common-prefix)))
252 (setf full-completed-string
253 (concatenate 'string directory-prefix completed-string)))
254 (case mode
255 ((:complete-limited :complete-maximal)
256 (cond ((null pathnames)
257 (values so-far nil nil 0 nil))
258 ((null (cdr pathnames))
259 (values completed-string t (car pathnames) 1 nil))
260 (t
261 (values completed-string nil nil (length pathnames) nil))))
262 (:complete
263 (cond ((null pathnames)
264 (values so-far t so-far 1 nil))
265 ((null (cdr pathnames))
266 (values completed-string t (car pathnames) 1 nil))
267 ((find full-completed-string strings :test #'string-equal)
268 (let ((pos (position full-completed-string strings :test #'string-equal)))
269 (values completed-string
270 t (elt pathnames pos) (length pathnames) nil)))
271 (t
272 (values completed-string nil nil (length pathnames) nil))))
273 (:possibilities
274 (values nil nil nil (length pathnames)
275 (loop with length = (length directory-prefix)
276 for name in pathnames
277 collect (list (subseq (namestring name) length nil)
278 name))))))))
279
280 (define-presentation-method accept
281 ((type completable-pathname) stream (view textual-view) &key)
282 (multiple-value-bind (pathname success string)
283 (complete-input stream
284 #'filename-completer
285 :partial-completers '(#\Space)
286 :allow-any-input t)
287 (declare (ignore success))
288 (or pathname string)))
289
290 (defun pathname-filename (pathname)
291 (if (null (pathname-type pathname))
292 (pathname-name pathname)
293 (concatenate 'string (pathname-name pathname)
294 "." (pathname-type pathname))))
295
296 (define-command (com-find-file :name "Find File" :command-table climacs) ()
297 (let ((filename (accept 'completable-pathname
298 :prompt "Find File")))
299 (with-slots (buffer point syntax) (win *application-frame*)
300 (setf buffer (make-instance 'climacs-buffer)
301 point (make-instance 'standard-right-sticky-mark :buffer buffer)
302 syntax (make-instance 'texinfo-syntax :pane (win *application-frame*)))
303 (with-open-file (stream filename :direction :input :if-does-not-exist :create)
304 (input-from-stream stream buffer 0))
305 (setf (filename buffer) filename
306 (name buffer) (pathname-filename filename))
307 (beginning-of-buffer point))))
308
309 (define-command com-save-buffer ()
310 (let ((filename (or (filename (buffer (win *application-frame*)))
311 (accept 'completable-pathname
312 :prompt "Save Buffer to File")))
313 (buffer (buffer (win *application-frame*))))
314 (with-open-file (stream filename :direction :output :if-exists :supersede)
315 (output-to-stream stream buffer 0 (size buffer)))
316 (setf (filename buffer) filename
317 (name buffer) (pathname-filename filename))
318 (setf (modified-p (buffer (win *application-frame*))) nil)))
319
320 (define-command com-write-buffer ()
321 (let ((filename (accept 'completable-pathname
322 :prompt "Write Buffer to File"))
323 (buffer (buffer (win *application-frame*))))
324 (with-open-file (stream filename :direction :output :if-exists :supersede)
325 (output-to-stream stream buffer 0 (size buffer)))
326 (setf (filename buffer) filename
327 (name buffer) (pathname-filename filename))
328 (setf (modified-p (buffer (win *application-frame*))) nil)))
329
330 (define-command com-beginning-of-buffer ()
331 (beginning-of-buffer (point (win *application-frame*))))
332
333 (define-command com-end-of-buffer ()
334 (end-of-buffer (point (win *application-frame*))))
335
336 (define-command com-browse-url ()
337 (accept 'url :prompt "Browse URL"))
338
339 (define-command com-set-mark ()
340 (with-slots (point mark) (win *application-frame*)
341 (setf mark (clone-mark point))))
342
343 ;;;;;;;;;;;;;;;;;;;;
344 ;; Kill ring commands
345
346 ;; The naming may sound odd here, but think of electronic wireing:
347 ;; outputs to inputs and inputs to outputs. Copying into a buffer
348 ;; first requires coping out of the kill ring.
349
350 (define-command com-copy-in ()
351 (kr-copy-out (point (win *application-frame*)) *kill-ring*))
352
353 (define-command com-cut-in ()
354 (kr-cut-out (point (win *application-frame*)) *kill-ring*))
355
356 (define-command com-cut-out ()
357 (with-slots (buffer point mark)(win *application-frame*)
358 (let ((off1 (offset point))
359 (off2 (offset mark)))
360 (if (< off1 off2)
361 (kr-cut-in buffer *kill-ring* off1 off2)
362 (kr-cut-in buffer *kill-ring* off2 off1)))))
363
364 (define-command com-copy-out ()
365 (with-slots (buffer point mark)(win *application-frame*)
366 (let ((off1 (offset point))
367 (off2 (offset mark)))
368 (if (< off1 off2)
369 (kr-copy-in buffer *kill-ring* off1 off2)
370 (kr-copy-in buffer *kill-ring* off2 off1)))))
371
372 ;; Needs adjustment to be like emacs M-y
373 (define-command com-kr-rotate ()
374 (kr-rotate *kill-ring* -1))
375
376 ;; Not bound to a key yet
377 (define-command com-kr-resize ()
378 (let ((size (accept 'fixnum :prompt "New kill ring size: ")))
379 (kr-resize *kill-ring* size)))
380
381
382 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
383 ;;;
384 ;;; Global command table
385
386 (make-command-table 'global-climacs-table :errorp nil)
387
388 (defun global-set-key (gesture command)
389 (add-command-to-command-table command 'global-climacs-table
390 :keystroke gesture :errorp nil))
391
392 (loop for code from (char-code #\space) to (char-code #\~)
393 do (global-set-key (code-char code) 'com-self-insert))
394
395 (global-set-key #\newline 'com-self-insert)
396 (global-set-key #\tab 'com-self-insert)
397 (global-set-key '(#\f :control) 'com-forward-object)
398 (global-set-key '(#\b :control) 'com-backward-object)
399 (global-set-key '(#\a :control) 'com-beginning-of-line)
400 (global-set-key '(#\e :control) 'com-end-of-line)
401 (global-set-key '(#\d :control) 'com-delete-object)
402 (global-set-key '(#\p :control) 'com-previous-line)
403 (global-set-key '(#\n :control) 'com-next-line)
404 (global-set-key '(#\o :control) 'com-open-line)
405 (global-set-key '(#\k :control) 'com-kill-line)
406 (global-set-key '(#\Space :control) 'com-set-mark)
407 (global-set-key '(#\y :control) 'com-copy-in)
408 (global-set-key '(#\w :control) 'com-cut-out)
409 (global-set-key '(#\f :meta) 'com-forward-word)
410 (global-set-key '(#\b :meta) 'com-backward-word)
411 (global-set-key '(#\x :meta) 'com-extended-command)
412 (global-set-key '(#\a :meta) 'com-insert-weird-stuff)
413 (global-set-key '(#\c :meta) 'com-insert-reversed-string)
414 (global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only
415 (global-set-key '(#\w :meta) 'com-copy-out)
416 (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer)
417 (global-set-key '(#\> :shift :meta) 'com-end-of-buffer)
418 (global-set-key '(#\u :meta) 'com-browse-url)
419
420 (global-set-key '(:up) 'com-previous-line)
421 (global-set-key '(:down) 'com-next-line)
422 (global-set-key '(:left) 'com-backward-object)
423 (global-set-key '(:right) 'com-forward-object)
424 (global-set-key '(:left :control) 'com-backward-word)
425 (global-set-key '(:right :control) 'com-forward-word)
426 (global-set-key '(:home) 'com-beginning-of-line)
427 (global-set-key '(:end) 'com-end-of-line)
428 (global-set-key '(:home :control) 'com-beginning-of-buffer)
429 (global-set-key '(:end :control) 'com-end-of-buffer)
430 (global-set-key #\Rubout 'com-delete-object)
431 (global-set-key #\Backspace 'com-backward-delete-object)
432
433 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
434 ;;;
435 ;;; C-x command table
436
437 (make-command-table 'c-x-climacs-table :errorp nil)
438
439 (add-menu-item-to-command-table 'global-climacs-table "C-x"
440 :menu 'c-x-climacs-table
441 :keystroke '(#\x :control))
442
443 (defun c-x-set-key (gesture command)
444 (add-command-to-command-table command 'c-x-climacs-table
445 :keystroke gesture :errorp nil))
446
447 (c-x-set-key '(#\c :control) 'com-quit)
448 (c-x-set-key '(#\f :control) 'com-find-file)
449 (c-x-set-key '(#\s :control) 'com-save-buffer)
450 (c-x-set-key '(#\w :control) 'com-write-buffer)

  ViewVC Help
Powered by ViewVC 1.1.5