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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (hide annotations)
Fri Dec 24 08:21:34 2004 UTC (9 years, 3 months ago) by rstrandh
Branch: MAIN
Changes since 1.11: +16 -11 lines
Implemented a basic syntax according to the syntax protocol
specification (which I haven't written yet). The current
implementation should be improved upon, but it basically shows how to
do it.

Also implemented a demo command that accepts a string and inserts its
reverse in the buffer.  This shows that the words in the buffer are
actually presentations (of type string) that become clickable by the
accept.

Added two missing methods on region-to-sequence.  There were no
methods when one of the arguments is an offset instead of a mark.
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     (setf syntax (make-instance 'basic-syntax :buffer buffer :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     :width 600 :height 400
50     :name 'win
51     :display-function 'display-win))
52 strandh 1.4 (int :interactor :width 600 :height 50))
53 strandh 1.1 (:layouts
54 strandh 1.3 (default
55 strandh 1.7 (vertically ()
56     (scrolling (:width 600 :height 400) win)
57     int)))
58 strandh 1.1 (:top-level (climacs-top-level)))
59    
60     (defun climacs ()
61 strandh 1.8 "Starts up a climacs session"
62 strandh 1.2 (let ((frame (make-application-frame 'climacs)))
63     (run-frame-top-level frame)))
64 strandh 1.1
65     (defun display-win (frame pane)
66 strandh 1.8 "The display function used by the climacs application frame."
67 rstrandh 1.10 (declare (ignore frame))
68 rstrandh 1.11 (redisplay-with-syntax pane (syntax pane)))
69 strandh 1.1
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 strandh 1.7 (setf (slot-value frame 'win) (find-pane-named frame 'win))
87 strandh 1.1 (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 strandh 1.6 (and (typep *current-gesture* 'keyboard-event)
95     (keyboard-event-character *current-gesture*)))
96 strandh 1.1 (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 strandh 1.4 (handler-case
102     (funcall (command-menu-item-value item))
103     (error (condition)
104     (beep)
105     (format *error-output* "~a~%" condition)))
106 strandh 1.1 (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 strandh 1.2 (unless (constituentp *current-gesture*)
115 strandh 1.7 (possibly-expand-abbrev (point (win *application-frame*))))
116     (insert-object (point (win *application-frame*)) *current-gesture*))
117 strandh 1.1
118 strandh 1.3 (define-command com-backward-object ()
119 strandh 1.7 (decf (offset (point (win *application-frame*)))))
120 strandh 1.1
121 strandh 1.3 (define-command com-forward-object ()
122 strandh 1.7 (incf (offset (point (win *application-frame*)))))
123 strandh 1.1
124     (define-command com-beginning-of-line ()
125 strandh 1.7 (beginning-of-line (point (win *application-frame*))))
126 strandh 1.1
127     (define-command com-end-of-line ()
128 strandh 1.7 (end-of-line (point (win *application-frame*))))
129 strandh 1.1
130 strandh 1.3 (define-command com-delete-object ()
131 strandh 1.7 (delete-range (point (win *application-frame*))))
132 strandh 1.1
133     (define-command com-previous-line ()
134 strandh 1.7 (previous-line (point (win *application-frame*))))
135 strandh 1.1
136     (define-command com-next-line ()
137 strandh 1.7 (next-line (point (win *application-frame*))))
138 strandh 1.1
139     (define-command com-open-line ()
140 strandh 1.7 (open-line (point (win *application-frame*))))
141 strandh 1.1
142     (define-command com-kill-line ()
143 strandh 1.7 (kill-line (point (win *application-frame*))))
144 strandh 1.1
145     (define-command com-forward-word ()
146 strandh 1.7 (forward-word (point (win *application-frame*))))
147 strandh 1.1
148     (define-command com-backward-word ()
149 strandh 1.7 (backward-word (point (win *application-frame*))))
150 strandh 1.1
151 strandh 1.3 (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 strandh 1.4 (define-command com-extended-command ()
158     (accept 'command :prompt "Extended Command"))
159    
160 strandh 1.8 (defclass weird () ()
161     (:documentation "An open ended class."))
162 strandh 1.3
163     (define-command com-insert-weird-stuff ()
164 strandh 1.7 (insert-object (point (win *application-frame*)) (make-instance 'weird)))
165 strandh 1.3
166 rstrandh 1.12 (define-command com-insert-reversed-string ()
167     (insert-sequence (point (win *application-frame*))
168     (reverse (accept 'string))))
169 strandh 1.5
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 strandh 1.7 (let ((filename (accept 'completable-pathname
245 rstrandh 1.12 :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 'basic-syntax :buffer buffer :pane (win *application-frame*))
250     (filename buffer) filename)
251     (with-open-file (stream filename :direction :input)
252     (input-from-stream stream buffer 0)))))
253 strandh 1.5
254 strandh 1.7 (define-command com-save-buffer ()
255     (let ((filename (or (filename (buffer (win *application-frame*)))
256     (accept 'completable-pathname
257     :prompt "Save Buffer to File")))
258     (buffer (buffer (win *application-frame*))))
259     (with-open-file (stream filename :direction :output :if-exists :supersede)
260     (output-to-stream stream buffer 0 (size buffer)))))
261    
262 strandh 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
263     ;;;
264     ;;; Global command table
265    
266     (make-command-table 'global-climacs-table :errorp nil)
267    
268     (defun global-set-key (gesture command)
269     (add-command-to-command-table command 'global-climacs-table
270     :keystroke gesture :errorp nil))
271    
272     (loop for code from (char-code #\space) to (char-code #\~)
273     do (global-set-key (code-char code) 'com-self-insert))
274    
275     (global-set-key #\newline 'com-self-insert)
276 rstrandh 1.10 (global-set-key #\tab 'com-self-insert)
277 strandh 1.3 (global-set-key '(#\f :control) 'com-forward-object)
278     (global-set-key '(#\b :control) 'com-backward-object)
279 strandh 1.1 (global-set-key '(#\a :control) 'com-beginning-of-line)
280     (global-set-key '(#\e :control) 'com-end-of-line)
281 strandh 1.3 (global-set-key '(#\d :control) 'com-delete-object)
282 strandh 1.1 (global-set-key '(#\p :control) 'com-previous-line)
283     (global-set-key '(#\n :control) 'com-next-line)
284     (global-set-key '(#\o :control) 'com-open-line)
285     (global-set-key '(#\k :control) 'com-kill-line)
286     (global-set-key '(#\f :meta) 'com-forward-word)
287     (global-set-key '(#\b :meta) 'com-backward-word)
288 strandh 1.4 (global-set-key '(#\x :meta) 'com-extended-command)
289 strandh 1.3 (global-set-key '(#\a :meta) 'com-insert-weird-stuff)
290 rstrandh 1.12 (global-set-key '(#\c :meta) 'com-insert-reversed-string)
291 strandh 1.1
292     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
293     ;;;
294     ;;; C-x command table
295    
296     (make-command-table 'c-x-climacs-table :errorp nil)
297    
298     (add-menu-item-to-command-table 'global-climacs-table "C-x"
299     :menu 'c-x-climacs-table
300     :keystroke '(#\x :control))
301    
302     ;;; for some reason, C-c does not seem to arrive as far as CLIM.
303    
304     (add-command-to-command-table 'com-quit 'c-x-climacs-table
305     :keystroke '(#\q :control))
306 strandh 1.5
307     (add-command-to-command-table 'com-find-file 'c-x-climacs-table
308     :keystroke '(#\f :control))
309 strandh 1.7
310     (add-command-to-command-table 'com-save-buffer 'c-x-climacs-table
311     :keystroke '(#\s :control))
312    
313 strandh 1.1
314    

  ViewVC Help
Powered by ViewVC 1.1.5