sly-buttons.el (12574B)
1 ;;; sly-buttons.el --- Button-related utils for SLY -*- lexical-binding: t; -*- 2 ;;; 3 (require 'cl-lib) 4 (require 'sly-messages "lib/sly-messages") 5 6 (defvar sly-part-button-keymap 7 (let ((map (make-sparse-keymap))) 8 (set-keymap-parent map button-map) 9 (define-key map [down-mouse-3] 'sly-button-popup-part-menu) 10 (define-key map [mouse-3] 'sly-button-popup-part-menu) 11 (define-key map [mouse-1] 'push-button) 12 (define-key map [return] 'push-button) 13 map)) 14 15 (defvar sly-button-popup-part-menu-keymap 16 (let ((map (make-sparse-keymap))) 17 map)) 18 19 (defun sly-button-popup-part-menu (event) 20 "Popup a menu for a `sly-part' button" 21 (interactive "@e") 22 (let* ((button (button-at (posn-point (event-end event)))) 23 (label (button-get button 'part-label)) 24 (items (cdr (button-get button 'part-menu-keymap)))) 25 (popup-menu 26 `(keymap 27 ,@(when label 28 `(,(truncate-string-to-width label 30 nil nil t))) 29 ,@items)))) 30 31 (defun sly-button-at (&optional pos type no-error) 32 (let ((button (button-at (or pos 33 (if (mouse-event-p last-input-event) 34 (posn-point (event-start last-input-event)) 35 (point)))))) 36 (cond ((and button type 37 (button-type-subtype-p (button-type button) type)) 38 button) 39 ((and button type) 40 (unless no-error 41 (error "[sly] Button at point is not of expected type %s" type))) 42 (button 43 button) 44 (t 45 (unless no-error 46 (error "[sly] No button at point")))))) 47 48 (defun sly-button-buttons-in (beg end) 49 (save-excursion 50 (goto-char (point-min)) 51 (cl-loop for count-current = t then nil 52 for button = (next-button (point) count-current) 53 while button 54 do (goto-char (button-start button)) 55 collect button))) 56 57 (defmacro sly-button-define-part-action (action label key) 58 `(progn 59 (defun ,action (button) 60 ,(format "%s the object under BUTTON." 61 label) 62 (interactive (list (sly-button-at))) 63 (let ((fn (button-get button ',action)) 64 (args (button-get button 'part-args))) 65 (if (and 66 (sly-current-connection) 67 (eq (button-get button 'sly-connection) 68 (sly-current-connection))) 69 (cond ((and fn args) 70 (apply fn args)) 71 (args 72 (sly-error "button of type `%s' doesn't implement `%s'" 73 (button-type button) ',action)) 74 (fn 75 (sly-error "button %s doesn't have the `part-args' property" 76 button))) 77 (sly-error (format "button is from an older connection"))))) 78 ,@(when key 79 `((define-key sly-part-button-keymap ,key 80 '(menu-item "" ,action 81 :filter (lambda (cmd) 82 (let ((button (sly-button-at nil nil 'no-error))) 83 (and button 84 (button-get button ',action) 85 cmd))))))) 86 (define-key sly-button-popup-part-menu-keymap 87 [,action] '(menu-item ,label ,action 88 :visible (let ((button (sly-button-at nil nil 'no-error))) 89 (and button 90 (button-get button ',action))))))) 91 92 (sly-button-define-part-action sly-button-inspect "Inspect" (kbd "i")) 93 (sly-button-define-part-action sly-button-describe "Describe" (kbd "d")) 94 (sly-button-define-part-action sly-button-pretty-print "Pretty Print" (kbd "p")) 95 (sly-button-define-part-action sly-button-show-source "Show Source" (kbd "v")) 96 (sly-button-define-part-action sly-button-goto-source "Go To Source" (kbd ".")) 97 98 (defun sly--make-text-button (beg end &rest properties) 99 "Just like `make-text-button', but add sly-specifics." 100 (apply #'make-text-button beg end 101 'sly-connection (sly-current-connection) 102 properties)) 103 104 (defun sly-make-action-button (label action &rest props) 105 (apply #'sly--make-text-button 106 label nil :type 'sly-action 107 'action action 108 'mouse-action action 109 props)) 110 111 (defface sly-action-face 112 `((t (:inherit warning))) 113 "Face for SLY buttons." 114 :group 'sly) 115 116 (define-button-type 'sly-button 117 'sly-button-search-id 'regular-button) 118 119 (define-button-type 'sly-action :supertype 'sly-button 120 'face 'sly-action-face 121 'mouse-face 'highlight 122 'sly-button-echo 'sly-button-echo-button) 123 124 (defface sly-part-button-face 125 '((t (:inherit font-lock-constant-face))) 126 "Face for things which be interactively inspected, etc" 127 :group 'sly) 128 129 (define-button-type 'sly-part :supertype 'sly-button 130 'face 'sly-part-button-face 131 'action 'sly-button-inspect 132 'mouse-action 'sly-button-inspect 133 'keymap sly-part-button-keymap 134 'sly-button-echo 'sly-button-echo-part 135 'part-menu-keymap sly-button-popup-part-menu-keymap 136 'help-echo "RET, mouse-2: Inspect object; mouse-3: Context menu" 137 ;; these are ajust here for clarity 138 ;; 139 'sly-button-inspect nil 140 'sly-button-describe nil 141 'sly-button-pretty-print nil 142 'sly-button-show-source nil) 143 144 (cl-defun sly-button-flash (button &key 145 (face 'highlight) 146 (pattern '(0.07 0.07 0.07 0.07)) 147 times 148 timeout) 149 (sly-flash-region (button-start button) (button-end button) 150 :timeout timeout 151 :pattern pattern 152 :times times 153 :face face)) 154 155 156 (defun sly-button-echo-button (button) (sly-message "A sly button")) 157 158 (defun sly-button-echo-part (button) 159 (sly-button-flash button) 160 (sly-message (button-get button 'part-label))) 161 162 163 ;;; Overlay-button specifics 164 ;;; 165 (defun sly-button--overlays-in (beg end &optional filter) 166 "Return overlays overlapping positions BEG and END" 167 (cl-remove-if-not #'(lambda (button) 168 (and 169 ;; Workaround fragility in Emacs' buttons: 170 ;; `button-type-subtype-p' errors when 171 ;; `button' is not actually a button. A 172 ;; straightforward predicate for this doesn't 173 ;; seem to exist yet. 174 (ignore-errors 175 (button-type-subtype-p (button-type button) 'sly-button)) 176 (or (not filter) 177 (funcall filter button)))) 178 (overlays-in beg end))) 179 180 (defun sly-button--overlays-between (beg end &optional filter) 181 "Return overlays contained entirely between BEG and END" 182 (cl-remove-if-not #'(lambda (button) 183 (and (>= (button-start button) beg) 184 (<= (button-end button) end))) 185 (sly-button--overlays-in beg end filter))) 186 187 (defun sly-button--overlays-exactly-at (beg end &optional filter) 188 "Return overlays exactly between BEG and END" 189 (cl-remove-if-not #'(lambda (button) 190 (and (= (button-start button) beg) 191 (= (button-end button) end))) 192 (sly-button--overlays-in beg end filter))) 193 194 (defun sly-button--overlays-at (&optional point filter) 195 "Return overlays near POINT" 196 (let ((point (or point (point)))) 197 (cl-sort (sly-button--overlays-in (1- point) (1+ point) filter) 198 #'> :key #'sly-button--level))) 199 200 (gv-define-setter sly-button--level (level button) 201 `(overlay-put ,button 'sly-button-level ,level)) 202 203 (defun sly-button--level (button) 204 (or (overlay-get button 'sly-button-level) 0)) 205 206 207 208 ;;; Button navigation 209 ;;; 210 (defvar sly-button--next-search-id 0) 211 212 (defun sly-button-next-search-id () 213 (cl-incf sly-button--next-search-id)) 214 215 (defun sly-button--searchable-buttons-at (pos filter) 216 (let* ((probe (sly-button-at pos 'sly-button 'no-error)) 217 (non-overlay-button (and probe 218 (not (overlayp probe)) 219 probe))) 220 (cl-remove-duplicates 221 (append (sly-button--overlays-at pos filter) 222 (if (and non-overlay-button 223 (or (not filter) 224 (funcall filter non-overlay-button))) 225 (list non-overlay-button)))))) 226 227 (defun sly-button--searchable-buttons-starting-at (&optional point filter) 228 (let ((point (or point (point)))) 229 (cl-remove-if-not #'(lambda (button) 230 (= (button-start button) point)) 231 (sly-button--searchable-buttons-at point filter)))) 232 233 (defun sly-button--search-1 (n filter) 234 (cl-loop with off-by-one = (if (cl-plusp n) -1 +1) 235 for search-start = (point) then pos 236 for preval = (and (not (cond ((cl-plusp n) 237 (= search-start (point-min))) 238 (t 239 (= search-start (point-max))))) 240 (get-char-property (+ off-by-one 241 search-start) 242 'sly-button-search-id)) 243 for pos = (funcall 244 (if (cl-plusp n) 245 #'next-single-char-property-change 246 #'previous-single-char-property-change) 247 search-start 248 'sly-button-search-id) 249 for newval = (get-char-property pos 'sly-button-search-id) 250 until (cond ((cl-plusp n) 251 (= pos (point-max))) 252 (t 253 (= pos (point-min)))) 254 for buttons = (sly-button--searchable-buttons-at 255 pos (or filter #'identity)) 256 when (and buttons 257 newval 258 (not (eq newval preval)) 259 (eq pos (button-start (car buttons)))) 260 return buttons)) 261 262 263 (put 'sly-button-forward 'sly-button-navigation-command t) 264 (put 'sly-button-backward 'sly-button-navigation-command t) 265 266 (defun sly-button-search (n &optional filter) 267 "Go forward to Nth buttons verifying FILTER and echo it. 268 269 With negative N, go backward. Visiting is done via the 270 `sly-button-echo' property. 271 272 If more than one button overlap the same region, the button 273 starting before is visited first. If more than one button start 274 at exactly the same spot, they are both visited simultaneously, 275 `sly-button-echo' being passed a variable number of button arguments." 276 (cl-loop for i from 0 below (abs n) 277 for buttons = 278 (or (and (not (and 279 ;; (symbolp last-command) 280 (get last-command 'sly-button-navigation-command))) 281 (sly-button--searchable-buttons-starting-at (point) filter)) 282 (sly-button--search-1 n filter)) 283 for button = (car buttons) 284 while buttons 285 finally 286 (cond (buttons 287 (goto-char (button-start (car buttons))) 288 (apply (button-get button 'sly-button-echo) 289 button 290 (cl-remove-if-not 291 #'(lambda (b) 292 (= (button-start b) (button-start button))) 293 (cdr buttons)))) 294 (t 295 (sly-user-error "No more buttons!"))))) 296 297 (defvar sly-button-filter-function #'identity 298 "Filter buttons considered by `sly-button-forward' 299 Set to `sly-note-button-p' to only navigate compilation notes, 300 or leave at `identity' to visit every `sly-button' in the buffer.'") 301 302 (defun sly-button-forward (n) 303 "Go to and describe the next button in the buffer." 304 (interactive "p") 305 (sly-button-search n sly-button-filter-function)) 306 307 (defun sly-button-backward (n) 308 "Go to and describe the previous button in the buffer." 309 (interactive "p") 310 (sly-button-forward (- n))) 311 312 (define-minor-mode sly-interactive-buttons-mode 313 "Minor mode where text property SLY buttons exist" 314 nil nil nil 315 ;; Prevent strings copied from SLY buffers and yanked to source 316 ;; buffers to land with misleading `sly-' properties. 317 (when (fboundp 'add-function) 318 (add-function :filter-return (local 'filter-buffer-substring-function) 319 #'substring-no-properties 320 '((name . sly-remove-string-properties))))) 321 322 (provide 'sly-buttons) 323 324 ;;; sly-buttons.el ends here