/[gtk-cffi]/cl-emacs/main.lisp
ViewVC logotype

Contents of /cl-emacs/main.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Sun May 13 16:20:49 2012 UTC (23 months, 1 week ago) by rklochkov
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +54 -50 lines
Minor fixes
1 ;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: emacs; -*-
2 (in-package :emacs)
3 (declaim (optimize safety debug))
4
5 (defvar *file*)
6 (defvar *region*)
7 (defvar *encoding*)
8
9
10 (defun on-key-press (widget event &rest rest)
11 (declare (ignore widget rest))
12
13 (let ((ret (when *entered-sequence* t)))
14 (setf *entered-sequence*
15 (nconc *entered-sequence*
16 (list (list (parse-event event :hardware-keycode)
17 (sort (intersection (parse-event event :state)
18 '(:shift :control :mod1))
19 #'symbol-name<)))))
20
21 (if (seq-processed *entered-sequence*)
22 (setf *entered-sequence* nil)
23 (setf ret t))
24
25 (let ((statusbar (object-by-id :status)))
26 (when statusbar
27 (let ((context-id (context-id statusbar :key-seq)))
28 (if *entered-sequence*
29 (statusbar-push statusbar context-id
30 (keyseq->string *entered-sequence*))
31 (statusbar-remove statusbar context-id)))))
32 ret))
33
34 (defun trap-error-handler (condition buf)
35 (with-output-to-string (s buf)
36 (format s "*** ~a~%" condition)))
37
38
39 (defun run-if-paired-parens ()
40 (let ((text (text (buffer (object-by-id :command))))
41 (parens 0))
42 ; (format t "~a~%" text)
43 (iter
44 (for c in-string text)
45 (case c
46 (#\( (incf parens))
47 (#\) (progn
48 (incf parens -1)
49 (when (< parens 0) (return-from run-if-paired-parens nil))))))
50 (when (eql parens 0)
51 (let ((repl (text (buffer (object-by-id :repl))))
52 (buf (make-array '(0) :element-type 'base-char
53 :fill-pointer 0 :adjustable t)))
54 (with-output-to-string (s buf)
55 (princ repl s)
56 (format s "~&=> ~a~%" text)
57 (handler-case
58 (handler-bind
59 ((warning (lambda (condition)
60 (with-output-to-string (s buf)
61 (format s "* ~a~%" condition))
62 (muffle-warning condition))))
63 (let ((res (eval (read-from-string text))))
64 (setf *** ** ** * * res)
65 (format s "~a~%" res)))
66 (t (var) (trap-error-handler var buf))))
67 (setf (text (buffer (object-by-id :repl))) buf))
68 (setf (text (buffer (object-by-id :command))) ""))
69 parens))
70
71
72
73 (defun on-command-key-press (widget event &rest rest)
74 (declare (ignore widget rest))
75 (let ((statusbar (object-by-id :status)))
76 (if (eql (parse-event event :keyval) (key "Return"))
77 (let ((parens (run-if-paired-parens)))
78 (statusbar-push statusbar (context-id statusbar :command)
79 (cond
80 ((null parens) "Close bracket without open")
81 ((> parens 0) "No close bracket")
82 ((< parens 0) "No open bracket")
83 (t "OK"))))
84 (statusbar-pop statusbar (context-id statusbar :command)))))
85
86 (defun open-file ()
87 (let ((d (make-instance 'file-chooser-dialog
88 :action :open
89 :parent (object-by-id :main)
90 :title "Open file")))
91 (when (eq (run d) :accept)
92 (setf (text (buffer (object-by-id :text)))
93 (with-open-file (s (filename d) :element-type '(unsigned-byte 8)
94 :if-does-not-exist :create)
95 (setf *file* (filename d))
96 (destroy d) ; filename fetched
97 (let ((res (make-array (file-length s)
98 :element-type '(unsigned-byte 8))))
99 (read-sequence res s)
100 (handler-case
101 (prog1
102 (babel:octets-to-string res :encoding :utf-8)
103 (setf *encoding* :utf-8))
104 (t nil
105 (prog1
106 (flexi-streams:octets-to-string
107 res :external-format :koi8-r)
108 (setf *encoding* :koi8-r)))))))
109 (let* ((statusbar (object-by-id :status))
110 (context-id (context-id statusbar :file)))
111 (statusbar-pop statusbar context-id)
112 (statusbar-push statusbar context-id
113 (format nil "Loaded ~a @ ~a" *file* *encoding*))))))
114
115 (defun save-file ()
116 (with-open-file (s *file* :element-type '(unsigned-byte 8)
117 :direction :output
118 :if-exists :supersede
119 :if-does-not-exist :create)
120 (let ((text (text (buffer (object-by-id :text)))))
121 (write-sequence (if (eq *encoding* :utf-8)
122 (babel:string-to-octets text :encoding :utf-8)
123 (flexi-streams:string-to-octets
124 text :external-format *encoding*)) s)))
125 (let* ((statusbar (object-by-id :status))
126 (context-id (context-id statusbar :file)))
127 (statusbar-pop statusbar context-id)
128 (statusbar-push statusbar context-id
129 (format nil "Saved ~a @ ~a" *file* *encoding*))))
130
131
132
133 (defmacro act (&body body)
134 `(lambda (&rest rest)
135 (declare (ignore rest))
136 ,@body))
137
138
139 (defun run-emacs ()
140 (gtk-init)
141 (global-set-key "C-x C-f" 'open-file)
142 (global-set-key "C-x C-c" (lambda () (destroy (object-by-id :main))))
143 (global-set-key "C-x C-s" 'save-file)
144 (show
145 (gtk-model
146 'window :signals '(:destroy :gtk-main-quit
147 :key-press-event on-key-press)
148 :width 800 :height 600 :title "Editor" :id :main
149 ('v-box
150 :expand nil
151 ('menu-bar
152 ('menu-item
153 :label "File"
154 :submenu
155 (gtk-model
156 'menu
157 ('menu-item :label "Open"
158 :signals `(:activate ,(act (open-file))))
159 ('menu-item :label "Save"
160 :signals `(:activate ,(act (save-file))))
161 ('menu-item :label "Quit"
162 :signals `(:activate
163 ,(act (destroy (object-by-id :main))))))))
164 :expand t
165 ('h-paned
166 :resize t
167 ('scrolled-window
168 ('text-view :id :text))
169 ('v-paned
170 ('scrolled-window
171 :min-content-height 100
172 ('text-view :id :command
173 :signals '(:key-press-event on-command-key-press)))
174 ('scrolled-window
175 ('text-view :id :repl))))
176 :expand nil
177 ('statusbar :id :status))))
178 (gtk-main))
179

  ViewVC Help
Powered by ViewVC 1.1.5