| 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, |
|---|
| 147 | and 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 |
|---|
| 151 | single action by undo mechanism. This variable is unique identifier |
|---|
| 152 | of 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 |
|---|
| 303 | for all the actions in the active keymap. |
|---|
| 304 | Example \(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 | |
|---|
