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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Thu Dec 23 08:00:33 2004 UTC (9 years, 4 months ago) by strandh
Branch: MAIN
Changes since 1.7: +9 -3 lines
Docstrings from Elliott Johnson.

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

  ViewVC Help
Powered by ViewVC 1.1.5