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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5