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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide 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 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     (syntax :initform (make-instance 'basic-syntax) :initarg :syntax :accessor syntax)))
36 strandh 1.7
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 strandh 1.1 (define-application-frame climacs ()
45 strandh 1.7 ((win :reader win))
46 strandh 1.1 (:panes
47 strandh 1.7 (win (make-pane 'climacs-pane
48     :width 600 :height 400
49     :name 'win
50     :display-function 'display-win))
51 strandh 1.4 (int :interactor :width 600 :height 50))
52 strandh 1.1 (:layouts
53 strandh 1.3 (default
54 strandh 1.7 (vertically ()
55     (scrolling (:width 600 :height 400) win)
56     int)))
57 strandh 1.1 (:top-level (climacs-top-level)))
58    
59     (defun climacs ()
60 strandh 1.8 "Starts up a climacs session"
61 strandh 1.2 (let ((frame (make-application-frame 'climacs)))
62     (run-frame-top-level frame)))
63 strandh 1.1
64     (defun display-win (frame pane)
65 strandh 1.8 "The display function used by the climacs application frame."
66 rstrandh 1.10 (declare (ignore frame))
67 rstrandh 1.11 (redisplay-with-syntax pane (syntax pane)))
68 strandh 1.1
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 strandh 1.7 (setf (slot-value frame 'win) (find-pane-named frame 'win))
86 strandh 1.1 (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 strandh 1.6 (and (typep *current-gesture* 'keyboard-event)
94     (keyboard-event-character *current-gesture*)))
95 strandh 1.1 (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 strandh 1.4 (handler-case
101     (funcall (command-menu-item-value item))
102     (error (condition)
103     (beep)
104     (format *error-output* "~a~%" condition)))
105 strandh 1.1 (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 strandh 1.2 (unless (constituentp *current-gesture*)
114 strandh 1.7 (possibly-expand-abbrev (point (win *application-frame*))))
115     (insert-object (point (win *application-frame*)) *current-gesture*))
116 strandh 1.1
117 strandh 1.3 (define-command com-backward-object ()
118 strandh 1.7 (decf (offset (point (win *application-frame*)))))
119 strandh 1.1
120 strandh 1.3 (define-command com-forward-object ()
121 strandh 1.7 (incf (offset (point (win *application-frame*)))))
122 strandh 1.1
123     (define-command com-beginning-of-line ()
124 strandh 1.7 (beginning-of-line (point (win *application-frame*))))
125 strandh 1.1
126     (define-command com-end-of-line ()
127 strandh 1.7 (end-of-line (point (win *application-frame*))))
128 strandh 1.1
129 strandh 1.3 (define-command com-delete-object ()
130 strandh 1.7 (delete-range (point (win *application-frame*))))
131 strandh 1.1
132     (define-command com-previous-line ()
133 strandh 1.7 (previous-line (point (win *application-frame*))))
134 strandh 1.1
135     (define-command com-next-line ()
136 strandh 1.7 (next-line (point (win *application-frame*))))
137 strandh 1.1
138     (define-command com-open-line ()
139 strandh 1.7 (open-line (point (win *application-frame*))))
140 strandh 1.1
141     (define-command com-kill-line ()
142 strandh 1.7 (kill-line (point (win *application-frame*))))
143 strandh 1.1
144     (define-command com-forward-word ()
145 strandh 1.7 (forward-word (point (win *application-frame*))))
146 strandh 1.1
147     (define-command com-backward-word ()
148 strandh 1.7 (backward-word (point (win *application-frame*))))
149 strandh 1.1
150 strandh 1.3 (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 strandh 1.4 (define-command com-extended-command ()
157     (accept 'command :prompt "Extended Command"))
158    
159 strandh 1.8 (defclass weird () ()
160     (:documentation "An open ended class."))
161 strandh 1.3
162     (define-command com-insert-weird-stuff ()
163 strandh 1.7 (insert-object (point (win *application-frame*)) (make-instance 'weird)))
164 strandh 1.3
165 strandh 1.5
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 strandh 1.7 (let ((filename (accept 'completable-pathname
241     :prompt "Find File"))
242     (buffer (make-instance 'climacs-buffer)))
243 strandh 1.8 (setf (buffer (win *application-frame*)) buffer
244 strandh 1.9 (filename (buffer (win *application-frame*))) filename)
245 strandh 1.6 (with-open-file (stream filename :direction :input)
246     (input-from-stream stream buffer 0))
247 strandh 1.7 (setf (slot-value (win *application-frame*) 'point)
248 strandh 1.6 (make-instance 'standard-right-sticky-mark :buffer buffer))))
249 strandh 1.5
250 strandh 1.7 (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 strandh 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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 rstrandh 1.10 (global-set-key #\tab 'com-self-insert)
273 strandh 1.3 (global-set-key '(#\f :control) 'com-forward-object)
274     (global-set-key '(#\b :control) 'com-backward-object)
275 strandh 1.1 (global-set-key '(#\a :control) 'com-beginning-of-line)
276     (global-set-key '(#\e :control) 'com-end-of-line)
277 strandh 1.3 (global-set-key '(#\d :control) 'com-delete-object)
278 strandh 1.1 (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 strandh 1.4 (global-set-key '(#\x :meta) 'com-extended-command)
285 strandh 1.3 (global-set-key '(#\a :meta) 'com-insert-weird-stuff)
286 strandh 1.1
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 strandh 1.5
302     (add-command-to-command-table 'com-find-file 'c-x-climacs-table
303     :keystroke '(#\f :control))
304 strandh 1.7
305     (add-command-to-command-table 'com-save-buffer 'c-x-climacs-table
306     :keystroke '(#\s :control))
307    
308 strandh 1.1
309    

  ViewVC Help
Powered by ViewVC 1.1.5