source: trunk/abcl/contrib/jfli/test/yanking.lisp @ 14258

Last change on this file since 14258 was 14258, checked in by Mark Evenson, 8 years ago

jfli: set svn:eol-style to native.

  • Property svn:eol-style set to native
File size: 14.8 KB
Line 
1(defpackage :my (:use :cl))
2(in-package :my)
3
4;; runtime-class.lisp is a part of ABCL, but it is excluded from ABCL build,
5;; because it requires asm.jar to be present in classpath during the build.
6;;
7;; The functionality it provides is necessary for dynamic creation of
8;; new java classes from Lisp (in particular for the
9;; NEW-CLASS macro of jfli ABCL port)
10(load (concatenate 'string abclidea:*lisp-dir* "org/armedbear/lisp/runtime-class.lisp"))
11
12;; Load jfli
13(load (concatenate 'string abclidea:*lisp-dir* "jfli-abcl/jfli-abcl.lisp"))
14
15(use-package :jfli)
16
17;; "Import" java classes we use.
18;;
19;; You may produce DEF-JAVA-CLASS forms for all the IDEA API classes automatically:
20;;
21;; (jfli:dump-wrapper-defs-to-file (concatenate 'string abclidea:*lisp-dir* "idea-api.lisp")
22;;                                 (jfli:get-jar-classnames "path/to/idea/openapi.jar"
23;;                                                          "com/intellij"))
24;;
25;;
26;; In result they will be stored in idea-api.lisp file.
27;;
28;; But we do it manually, because there are not so many classes we use.
29
30(def-java-class "com.intellij.openapi.ui.Messages")
31(use-package "com.intellij.openapi.ui")
32
33(def-java-class "com.intellij.openapi.application.ModalityState")
34(def-java-class "com.intellij.openapi.application.Application")
35(def-java-class "com.intellij.openapi.application.ApplicationManager")
36(use-package "com.intellij.openapi.application")
37
38(def-java-class "com.intellij.openapi.actionSystem.AnAction")
39(def-java-class "com.intellij.openapi.actionSystem.AnActionEvent")
40(def-java-class "com.intellij.openapi.actionSystem.ActionManager")
41(def-java-class "com.intellij.openapi.actionSystem.DefaultActionGroup")
42(def-java-class "com.intellij.openapi.actionSystem.CustomShortcutSet")
43(def-java-class "com.intellij.openapi.actionSystem.Shortcut")
44(def-java-class "com.intellij.openapi.actionSystem.KeyboardShortcut")
45(def-java-class "com.intellij.openapi.actionSystem.CustomShortcutSet")
46(use-package "com.intellij.openapi.actionSystem")
47
48(def-java-class "com.intellij.openapi.ide.CopyPasteManager")
49(use-package "com.intellij.openapi.ide")
50
51(def-java-class "com.intellij.openapi.keymap.KeymapManager")
52(def-java-class "com.intellij.openapi.keymap.Keymap")
53(use-package "com.intellij.openapi.keymap")
54
55(def-java-class "com.intellij.openapi.project.ProjectManager")
56(use-package "com.intellij.openapi.project")
57
58(def-java-class "com.intellij.openapi.editor.Editor")
59(def-java-class "com.intellij.openapi.editor.Document")
60(def-java-class "com.intellij.openapi.editor.SelectionModel")
61(use-package "com.intellij.openapi.editor")
62
63(def-java-class "com.intellij.openapi.fileEditor.FileEditorManager")
64(def-java-class "com.intellij.openapi.fileEditor.FileEditor")
65(def-java-class "com.intellij.openapi.fileEditor.TextEditor")
66(use-package "com.intellij.openapi.fileEditor")
67
68(def-java-class "com.intellij.openapi.command.CommandProcessor")
69(def-java-class "com.intellij.openapi.command.CommandAdapter")
70(def-java-class "com.intellij.openapi.command.CommandEvent")
71(use-package "com.intellij.openapi.command")
72
73(def-java-class "com.intellij.openapi.wm.WindowManager")
74(def-java-class "com.intellij.openapi.wm.StatusBar")
75(use-package "com.intellij.openapi.wm")
76
77(def-java-class "java.lang.Runnable")
78(def-java-class "java.lang.Thread")
79(def-java-class "java.lang.Object")
80(def-java-class "java.lang.Class")
81(def-java-class "java.lang.String")
82(use-package "java.lang")
83
84(def-java-class "java.awt.datatransfer.Transferable")
85(def-java-class "java.awt.datatransfer.DataFlavor")
86(use-package "java.awt.datatransfer")
87
88(def-java-class "javax.swing.KeyStroke")
89(use-package "javax.swing")
90
91(define-condition action-is-not-applicable ()
92  ((why :initarg :why :reader why))
93  (:report (lambda (condition stream)
94             (format stream "Action is not applicable: ~A" (why condition)))))
95
96(defun cur-prj ()
97  (let ((all-prjs (projectmanager.getopenprojects (projectmanager.getinstance))))
98    (when (> (jlength all-prjs) 0)
99      (jref all-prjs 0))))
100
101(defun cur-prj-safe ()
102  (or (cur-prj) (error 'action-is-not-applicable :why "no current project")))
103
104(defun cur-editor (prj)
105  (fileeditormanager.getselectedtexteditor (fileeditormanager.getinstance prj)))
106
107(defun cur-editor-safe (prj)
108  (or (cur-editor prj) 
109      (error 'action-is-not-applicable 
110             :why "no text editor is selected")))
111
112;; region object
113(defun make-region (start end)
114  (cons start end))
115
116(defun region-start (region)
117  (car region))
118
119(defun region-end (region)
120  (cdr region))
121
122(defun get-sel-region()
123  "Selection in the currently active editor"
124  (let* ((cur-prj (cur-prj-safe))
125         (cur-editor (cur-editor-safe cur-prj))
126         (sel-model (editor.getselectionmodel cur-editor)))
127    (make-region 
128       (selectionmodel.getselectionstart sel-model)
129       (selectionmodel.getselectionend sel-model))))
130
131(defun replace-region (replacement-text region)
132  "Replace text in the curently active editor"
133  (let* ((cur-prj (cur-prj-safe))
134         (cur-editor (cur-editor-safe cur-prj))
135         (cur-doc (editor.getdocument cur-editor)))
136    (document.replacestring cur-doc 
137                            (region-start region)
138                            (region-end region)
139                            replacement-text)))
140
141(defvar *yank-index* 0
142    "Index of clipboard item that will be pasted by the next yank or
143 yank-pop operation \(similar to kill-ring-yank-pointer in Emacs\).")
144
145(defvar *yank-region* nil
146    "Region of text that was inserted by previous yank or yank-pop command,
147and that must be replaced by next yank-pop.")
148
149(defvar *yank-undo-id* 0
150    "Yank following by a sequence of yank-pop must be considered as a
151single action by undo mechanism. This variable is unique identifier
152of such an compound action.")
153
154(defun get-yank-text (&optional (index 0))
155  (let ((all-contents (copypastemanager.getallcontents (copypastemanager.getinstance)))
156        content)
157    (when (zerop (jlength all-contents))
158      (RETURN-FROM get-yank-tex nil))
159    (setf content (jref all-contents (mod index (jlength all-contents))))
160    (transferable.gettransferdata content (dataflavor.stringflavor))))
161
162(defun get-yank-text-safe (&optional (index 0))
163  (or (get-yank-text index) 
164      (error 'action-is-not-applicable :why "clipboard is empty")))
165
166(defun next-yank-region (cur-selection-region replacement-text)
167  (make-region (region-start cur-selection-region)
168               (+ (region-start cur-selection-region)
169                  (length (java:jobject-lisp-value replacement-text)))))
170(defun yank()
171  (let ((sel-region (get-sel-region))
172        (yank-text (get-yank-text-safe)))
173    (replace-region yank-text
174                    sel-region)
175    (setf *yank-region* (next-yank-region sel-region 
176                                          yank-text))
177    (setf *yank-index* 1)))
178
179(defun make-runnable (fun)
180  (java:jinterface-implementation 
181   "java.lang.Runnable"
182   "run"
183   ;; wrap FUN into lambda to allow it to be
184   ;; not only function objects, but also symbols
185   ;; (java:jinterface-implementation supports
186   ;; only function objects)
187   (lambda () (funcall fun))))
188
189(defmacro runnable (&body body)
190  `(make-runnable (lambda () ,@body)))
191
192(defun run-write-action (fun)
193  (let ((app (applicationmanager.getapplication))
194        (runnable (make-runnable fun)))
195    (application.runwriteaction app runnable)))
196
197(defun exec-cmd (fun name group-id)
198  (commandprocessor.executecommand (commandprocessor.getinstance)
199                                   (cur-prj)
200                                   (make-runnable fun)
201                                   name
202                                   group-id))
203
204;; set status bar text
205(defun set-status (status-text)
206  (statusbar.setinfo (windowmanager.getstatusbar 
207                      (windowmanager.getinstance) 
208                      (cur-prj))
209                     status-text))
210
211(new-class 
212 "MY.MyAction" ;; class name
213 anaction. ;; super class
214
215 ;; constructors
216 (
217  (((text "java.lang.String") (func "java.lang.Object"))
218   (super text)
219   (setf (myaction.func this) func))
220  )
221 
222 ;; methods
223 ( 
224  ("actionPerformed" :void :public (action-event) 
225                     ;; It's usefull to setup a restart before
226                     ;; calling FUNC.
227                     ;;
228                     ;; It helps when slime is connected to
229                     ;; the IDEA and error happens
230                     ;; during action execution.
231                     ;;
232                     ;; Slime debugger hooks the error,
233                     ;; but as actions are invoked from
234                     ;; idea UI event dispatching thread,
235                     ;; no slime restarts are set
236                     ;; and our restart is the only
237                     ;; way to leave SLIME debugger.
238                     (restart-case
239                         (handler-case
240                             (funcall (myaction.func this) action-event)
241                           (action-is-not-applicable ()
242                             ;; NOTE: it is not guaranteed
243                             ;; that execution will be passed to this
244                             ;; handler, even if your code signals
245                             ;; ACTION-IS-NOT-APPLICABLE.
246                             ;;
247                             ;; It's so because ABCL impements
248                             ;; non local exits using java exceptions
249                             ;; (org.armedbear.lisp.Go); if somewhere
250                             ;; in the call stack below our HANDLER-CASE
251                             ;; and above the SIGNAL there is a
252                             ;;
253                             ;;    catch (Throwable)
254                             ;;
255                             ;; then ABCL's Go exception will be catched.
256                             ;;
257                             ;; catch (Throwable) is in partiular
258                             ;; used by IDEA methods that accept Runnable
259                             ;; (like CommandProcessor.executeCommand,
260                             ;; Application.runWriteAction)
261                             ;;
262                             ;; But even despite that, HANDLER-CASE
263                             ;; is useful, because ACTION-IS-NOT-APPLICABLE
264                             ;; is not trapped by Slime debugger.
265                             ))
266                       (continue () 
267                         :report "Return from IDEA action"
268                         nil)))
269  )
270
271  ;; fields
272 (
273  ("func" "java.lang.Object" :public))
274 )
275
276(setf act-yank (myaction.new "yank" nil))
277(setf (myaction.func act-yank)
278      #'(lambda (action-event) 
279          (declare (ignore action-event))
280          (incf *yank-undo-id*)
281          (exec-cmd (lambda () 
282                      (run-write-action 'yank)) 
283                    "yank" 
284                    (format nil "yank-~A" *yank-undo-id*))))
285
286(setf edit-menu (actionmanager.getaction (actionmanager.getinstance) "EditMenu"))
287
288(actionmanager.registeraction (actionmanager.getinstance) "yank" act-yank)
289(defaultactiongroup.add edit-menu act-yank)
290
291;;(actionmanager.unregisteraction (actionmanager.getinstance) "yank")
292;;(defaultactiongroup.remove edit-menu act-yank)
293
294;; assign keyboard shortcut Ctrl-Y to our action
295;; (by default Ctrl-Y is used for delete-line operation in IDEA;
296;; override this by unregistering Ctrl-Y from delete-line)
297(defun action-shortcut (anaction)
298  "The first element of AnAction.getShorcuts()"
299  (jref (customshortcutset.getshortcuts (anaction.getshortcutset anaction)) 0))
300
301(defun remove-shortcut (keystroke-str)
302  "Unregister all the shortcuts specified by KEYSTROKE-STR
303for all the actions in the active keymap.
304Example \(REMOVE-SHORTCUT \"control Y\"\)"
305  (let* ((keymap (keymapmanager.getactivekeymap (keymapmanager.getinstance)))
306         (keystroke (keystroke.getkeystroke keystroke-str))
307         (act-ids (keymap.getactionids keymap keystroke)))
308    (dotimes (i (jlength act-ids))
309      (let ((shortcuts (keymap.getshortcuts keymap (jref act-ids i))))
310        (dotimes (j (jlength shortcuts))
311          (let ((shortcut (jref shortcuts j)))
312            (when (class.isinstance (class.forname "com.intellij.openapi.actionSystem.KeyboardShortcut")
313                                    shortcut)
314              (when (jeq (keyboardshortcut.getfirstkeystroke shortcut)
315                         keystroke)
316                (keymap.removeshortcut keymap (jref act-ids i) shortcut)))))))))
317
318;; this is to display shortcut correctly in the menu
319(anaction.setshortcutset act-yank 
320                         (customshortcutset.new (keystroke.getkeystroke "control Y")))
321
322;; this is to make it actually fired when user presses the key combination
323(remove-shortcut "control Y")
324(keymap.addshortcut (keymapmanager.getactivekeymap (keymapmanager.getinstance))
325                    "yank"
326                    (action-shortcut act-yank))
327
328;; yank-pop is allowed only if previous command was yank or yank-pop.
329;; Add a command listentener that clears *yank-region* when any
330;; other command is executed, and thus makes yank-pop impossible.
331(new-class 
332 "MY.MyCommandListener" ;; class name
333 commandadapter. ;; super class
334
335 ;; constructors
336 ()
337 
338 ;; methods
339 ( 
340  ("commandFinished" :void :public (command-event) 
341                     (unless (member (java:jobject-lisp-value (commandevent.getcommandname 
342                                                                command-event))
343                                     '("yank" "yank-pop")
344                                     :test #'string=)
345                       (setf *yank-region* nil)))
346  )
347
348  ;; fields
349 ()
350 )
351
352(setf my-cmd-listener (mycommandlistener.new))
353(commandprocessor.addcommandlistener (commandprocessor.getinstance)
354                                     my-cmd-listener)
355
356;; (actionmanager.unregisteraction (actionmanager.getinstance) "yank-pop")
357;; (defaultactiongroup.remove edit-menu act-yank-pop)
358
359(defun yank-pop ()
360  (let ((yank-text (get-yank-text *yank-index*))) 
361    (replace-region yank-text *yank-region*)
362    (setf *yank-region* (make-region (region-start *yank-region*)
363                                     (+ (region-start *yank-region*)
364                                        (string.length yank-text)))))
365  (incf *yank-index*))
366
367(setf act-yank-pop (myaction.new "yank-pop" nil))
368(setf (myaction.func act-yank-pop)
369      #'(lambda (action-event)
370          (if *yank-region* 
371              (exec-cmd (lambda () 
372                          (run-write-action 'yank-pop)) 
373                        "yank-pop" 
374                        (format nil "yank-~A" *yank-undo-id*))
375              (set-status "Previous command was not a yank"))))
376
377(actionmanager.registeraction (actionmanager.getinstance) "yank-pop" act-yank-pop)
378(defaultactiongroup.add edit-menu act-yank-pop)
379
380(anaction.setshortcutset act-yank-pop 
381                         (customshortcutset.new (keystroke.getkeystroke "alt Y")))
382
383(keymap.addshortcut (keymapmanager.getactivekeymap (keymapmanager.getinstance))
384                    "yank-pop"
385                    (action-shortcut act-yank-pop))
386
Note: See TracBrowser for help on using the repository browser.