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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5