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

Contents of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5