sly-package-fu.el (18512B)
1 ;; -*- lexical-binding: t; -*- 2 (require 'sly) 3 (require 'sly-parse "lib/sly-parse") 4 5 (define-sly-contrib sly-package-fu 6 "Exporting/Unexporting symbols at point." 7 (:authors "Tobias C. Rittweiler <tcr@freebits.de>") 8 (:license "GPL") 9 (:slynk-dependencies slynk/package-fu) 10 (:on-load 11 (define-key sly-mode-map "\C-cx" 'sly-export-symbol-at-point) 12 (define-key sly-mode-map "\C-ci" 'sly-import-symbol-at-point)) 13 (:on-unload 14 ;; FIXME: To properly support unloading, this contrib should be 15 ;; made a minor mode with it's own keymap. The minor mode 16 ;; activation function should be added to the proper sly-* hooks. 17 ;; 18 )) 19 20 (defvar sly-package-file-candidates 21 (mapcar #'file-name-nondirectory 22 '("package.lisp" "packages.lisp" "pkgdcl.lisp" 23 "defpackage.lisp"))) 24 25 (defvar sly-export-symbol-representation-function 26 #'(lambda (n) (format "#:%s" n))) 27 28 (defvar sly-import-symbol-package-transform-function 29 'identity 30 "String transformation used by `sly-import-symbol-at-point'. 31 32 This function is applied to a package name before it is inserted 33 into the defpackage form. By default, it is `identity' but you 34 may wish redefine it to do some tranformations, for example, to 35 replace dots with slashes to conform to a package-inferred ASDF 36 system-definition style.") 37 38 (defvar sly-export-symbol-representation-auto t 39 "Determine automatically which style is used for symbols, #: or : 40 If it's mixed or no symbols are exported so far, 41 use `sly-export-symbol-representation-function'.") 42 43 (define-obsolete-variable-alias 'sly-export-save-file 44 'sly-package-fu-save-file "1.0.0-beta-3") 45 46 (defvar sly-package-fu-save-file nil 47 "Save the package file after each automatic modification") 48 49 (defvar sly-defpackage-regexp 50 "^(\\(cl:\\|common-lisp:\\|uiop:\\|\\uiop/package:\\)?\\(defpackage\\|define-package\\)\\>[ \t']*") 51 52 (put 'uiop:define-package 'sly-common-lisp-indent-function '(as defpackage)) 53 54 (defun sly-find-package-definition-rpc (package) 55 (sly-eval `(slynk:find-definition-for-thing 56 (slynk::guess-package ,package)))) 57 58 (defun sly-find-package-definition-regexp (package) 59 (save-excursion 60 (save-match-data 61 (goto-char (point-min)) 62 (cl-block nil 63 (while (re-search-forward sly-defpackage-regexp nil t) 64 (when (sly-package-equal package (sly-sexp-at-point)) 65 (backward-sexp) 66 (cl-return (make-sly-file-location (buffer-file-name) 67 (1- (point)))))))))) 68 69 (defun sly-package-equal (designator1 designator2) 70 ;; First try to be lucky and compare the strings themselves (for the 71 ;; case when one of the designated packages isn't loaded in the 72 ;; image.) Then try to do it properly using the inferior Lisp which 73 ;; will also resolve nicknames for us &c. 74 (or (cl-equalp (sly-cl-symbol-name designator1) 75 (sly-cl-symbol-name designator2)) 76 (sly-eval `(slynk:package= ,designator1 ,designator2)))) 77 78 (defun sly-export-symbol (symbol package) 79 "Unexport `symbol' from `package' in the Lisp image." 80 (sly-eval `(slynk:export-symbol-for-emacs ,symbol ,package))) 81 82 (defun sly-unexport-symbol (symbol package) 83 "Export `symbol' from `package' in the Lisp image." 84 (sly-eval `(slynk:unexport-symbol-for-emacs ,symbol ,package))) 85 86 87 (defun sly-find-possible-package-file (buffer-file-name) 88 (cl-labels ((file-name-subdirectory (dirname) 89 (expand-file-name 90 (concat (file-name-as-directory (sly-to-lisp-filename dirname)) 91 (file-name-as-directory "..")))) 92 (try (dirname) 93 (cl-dolist (package-file-name sly-package-file-candidates) 94 (let ((f (sly-to-lisp-filename 95 (concat dirname package-file-name)))) 96 (when (file-readable-p f) 97 (cl-return f)))))) 98 (when buffer-file-name 99 (let ((buffer-cwd (file-name-directory buffer-file-name))) 100 (or (try buffer-cwd) 101 (try (file-name-subdirectory buffer-cwd)) 102 (try (file-name-subdirectory 103 (file-name-subdirectory buffer-cwd)))))))) 104 105 (defun sly-goto-package-source-definition (package) 106 "Tries to find the DEFPACKAGE form of `package'. If found, 107 places the cursor at the start of the DEFPACKAGE form." 108 (cl-labels ((try (location) 109 (when (sly-location-p location) 110 (sly-move-to-source-location location) 111 t))) 112 (or (try (sly-find-package-definition-rpc package)) 113 (try (sly-find-package-definition-regexp package)) 114 (try (sly--when-let 115 (package-file (sly-find-possible-package-file 116 (buffer-file-name))) 117 (with-current-buffer (find-file-noselect package-file t) 118 (sly-find-package-definition-regexp package)))) 119 (sly-error "Couldn't find source definition of package: %s" package)))) 120 121 (defun sly-at-expression-p (pattern) 122 (when (ignore-errors 123 ;; at a list? 124 (= (point) (progn (down-list 1) 125 (backward-up-list 1) 126 (point)))) 127 (save-excursion 128 (down-list 1) 129 (sly-in-expression-p pattern)))) 130 131 (defun sly-goto-next-export-clause () 132 ;; Assumes we're inside the beginning of a DEFPACKAGE form. 133 (let ((point)) 134 (save-excursion 135 (cl-block nil 136 (while (ignore-errors (sly-forward-sexp) t) 137 (skip-chars-forward " \n\t") 138 (when (sly-at-expression-p '(:export *)) 139 (setq point (point)) 140 (cl-return))))) 141 (if point 142 (goto-char point) 143 (error "No next (:export ...) clause found")))) 144 145 (defun sly-search-exports-in-defpackage (symbol-name) 146 "Look if `symbol-name' is mentioned in one of the :EXPORT clauses." 147 ;; Assumes we're inside the beginning of a DEFPACKAGE form. 148 (cl-labels ((target-symbol-p (symbol) 149 (string-match-p (format "^\\(\\(#:\\)\\|:\\)?%s$" 150 (regexp-quote symbol-name)) 151 symbol))) 152 (save-excursion 153 (cl-block nil 154 (while (ignore-errors (sly-goto-next-export-clause) t) 155 (let ((clause-end (save-excursion (forward-sexp) (point)))) 156 (save-excursion 157 (while (search-forward symbol-name clause-end t) 158 (when (target-symbol-p (sly-symbol-at-point)) 159 (cl-return (if (sly-inside-string-p) 160 ;; Include the following " 161 (1+ (point)) 162 (point)))))))))))) 163 164 165 (defun sly-package-fu--read-symbols () 166 "Reads sexps as strings from the point to end of sexp. 167 168 For example, in this situation. 169 170 (for<point> bar minor (again 123)) 171 172 this will return (\"bar\" \"minor\" \"(again 123)\")" 173 (cl-labels ((read-sexp () 174 (ignore-errors 175 (forward-comment (point-max)) 176 (buffer-substring-no-properties 177 (point) (progn (forward-sexp) (point)))))) 178 (save-excursion 179 (cl-loop for sexp = (read-sexp) while sexp collect sexp)))) 180 181 (defun sly-package-fu--normalize-name (name) 182 (if (string-prefix-p "\"" name) 183 (read name) 184 (replace-regexp-in-string "^\\(\\(#:\\)\\|:\\)" 185 "" name))) 186 187 (defun sly-defpackage-exports () 188 "Return a list of symbols inside :export clause of a defpackage." 189 ;; Assumes we're inside the beginning of a DEFPACKAGE form. 190 (save-excursion 191 (mapcar #'sly-package-fu--normalize-name 192 (cl-loop while (ignore-errors (sly-goto-next-export-clause) t) 193 do (down-list) (forward-sexp) 194 append (sly-package-fu--read-symbols) 195 do (up-list) (backward-sexp))))) 196 197 (defun sly-symbol-exported-p (name symbols) 198 (cl-member name symbols :test 'cl-equalp)) 199 200 (defun sly-frob-defpackage-form (current-package do-what symbols) 201 "Adds/removes `symbol' from the DEFPACKAGE form of `current-package' 202 depending on the value of `do-what' which can either be `:export', 203 or `:unexport'. 204 205 Returns t if the symbol was added/removed. Nil if the symbol was 206 already exported/unexported." 207 (save-excursion 208 (sly-goto-package-source-definition current-package) 209 (down-list 1) ; enter DEFPACKAGE form 210 (forward-sexp) ; skip DEFPACKAGE symbol 211 ;; Don't or will fail if (:export ...) is immediately following 212 ;; (forward-sexp) ; skip package name 213 (let ((exported-symbols (sly-defpackage-exports)) 214 (symbols (if (consp symbols) 215 symbols 216 (list symbols))) 217 (number-of-actions 0)) 218 (cl-ecase do-what 219 (:export 220 (sly-add-export) 221 (dolist (symbol symbols) 222 (let ((symbol-name (sly-cl-symbol-name symbol))) 223 (unless (sly-symbol-exported-p symbol-name exported-symbols) 224 (cl-incf number-of-actions) 225 (sly-package-fu--insert-symbol symbol-name))))) 226 (:unexport 227 (dolist (symbol symbols) 228 (let ((symbol-name (sly-cl-symbol-name symbol))) 229 (when (sly-symbol-exported-p symbol-name exported-symbols) 230 (sly-remove-export symbol-name) 231 (cl-incf number-of-actions)))))) 232 (when sly-package-fu-save-file 233 (save-buffer)) 234 (cons number-of-actions 235 (current-buffer))))) 236 237 (defun sly-add-export () 238 (let (point) 239 (save-excursion 240 (while (ignore-errors (sly-goto-next-export-clause) t) 241 (setq point (point)))) 242 (cond (point 243 (goto-char point) 244 (down-list) 245 (sly-end-of-list)) 246 (t 247 (sly-end-of-list) 248 (unless (looking-back "^\\s-*" (line-beginning-position) nil) 249 (newline-and-indent)) 250 (insert "(:export ") 251 (save-excursion (insert ")")))))) 252 253 (defun sly-determine-symbol-style () 254 ;; Assumes we're inside :export 255 (save-excursion 256 (sly-beginning-of-list) 257 (sly-forward-sexp) 258 (let ((symbols (sly-package-fu--read-symbols))) 259 (cond ((null symbols) 260 sly-export-symbol-representation-function) 261 ((cl-every (lambda (x) 262 (string-match "^:" x)) 263 symbols) 264 (lambda (n) (format ":%s" n))) 265 ((cl-every (lambda (x) 266 (string-match "^#:" x)) 267 symbols) 268 (lambda (n) (format "#:%s" n))) 269 ((cl-every (lambda (x) 270 (string-prefix-p "\"" x)) 271 symbols) 272 (lambda (n) (prin1-to-string (upcase (substring-no-properties n))))) 273 (t 274 sly-export-symbol-representation-function))))) 275 276 (defun sly-format-symbol-for-defpackage (symbol-name) 277 (funcall (if sly-export-symbol-representation-auto 278 (sly-determine-symbol-style) 279 sly-export-symbol-representation-function) 280 symbol-name)) 281 282 (defun sly-package-fu--insert-symbol (symbol-name) 283 ;; Assumes we're at the inside :export or :import-from form 284 ;; after the last symbol 285 (let ((symbol-name (sly-format-symbol-for-defpackage symbol-name))) 286 (unless (looking-back "^\\s-*" (line-beginning-position) nil) 287 (newline-and-indent)) 288 (insert symbol-name))) 289 290 (defun sly-remove-export (symbol-name) 291 ;; Assumes we're inside the beginning of a DEFPACKAGE form. 292 (let ((point)) 293 (while (setq point (sly-search-exports-in-defpackage symbol-name)) 294 (save-excursion 295 (goto-char point) 296 (backward-sexp) 297 (delete-region (point) point) 298 (beginning-of-line) 299 (when (looking-at "^\\s-*$") 300 (join-line) 301 (delete-trailing-whitespace (point) (line-end-position))))))) 302 303 (defun sly-export-symbol-at-point () 304 "Add the symbol at point to the defpackage source definition 305 belonging to the current buffer-package. With prefix-arg, remove 306 the symbol again. Additionally performs an EXPORT/UNEXPORT of the 307 symbol in the Lisp image if possible." 308 (interactive) 309 (let* ((symbol (sly-symbol-at-point)) 310 (package (or (and (string-match "^\\([^:]+\\):.*" symbol) 311 (match-string 1 symbol)) 312 (sly-current-package)))) 313 (unless symbol (error "No symbol at point.")) 314 (cond (current-prefix-arg 315 (let* ((attempt (sly-frob-defpackage-form package :unexport symbol)) 316 (howmany (car attempt)) 317 (where (buffer-file-name (cdr attempt)))) 318 (if (cl-plusp howmany) 319 (sly-message "Symbol `%s' no longer exported from `%s' in %s" 320 symbol package where) 321 (sly-message "Symbol `%s' is not exported from `%s' in %s" 322 symbol package where))) 323 (sly-unexport-symbol symbol package)) 324 (t 325 (let* ((attempt (sly-frob-defpackage-form package :export symbol)) 326 (howmany (car attempt)) 327 (where (buffer-file-name (cdr attempt)))) 328 (if (cl-plusp howmany) 329 (sly-message "Symbol `%s' now exported from `%s' in %s" 330 symbol package where) 331 (sly-message "Symbol `%s' already exported from `%s' in %s" 332 symbol package where))) 333 (sly-export-symbol symbol package))))) 334 335 (defun sly-export-class (name) 336 "Export acessors, constructors, etc. associated with a structure or a class" 337 (interactive (list (sly-read-from-minibuffer "Export structure named: " 338 (sly-symbol-at-point)))) 339 (let* ((package (sly-current-package)) 340 (symbols (sly-eval `(slynk:export-structure ,name ,package)))) 341 (sly-message "%s symbols exported from `%s'" 342 (car (sly-frob-defpackage-form package :export symbols)) 343 package))) 344 345 (defalias 'sly-export-structure 'sly-export-class) 346 347 ;; 348 ;; Dealing with import-from 349 ;; 350 351 (defun sly-package-fu--search-import-from (package) 352 ;; Suppose, we are in the defpackage sexp 353 (let* ((normalized-package (sly-package-fu--normalize-name package)) 354 (regexp (format "(:import-from[ \t']*\\(:\\|#:\\)?%s" 355 (regexp-quote (regexp-quote normalized-package)))) 356 (search-result (re-search-forward regexp nil t))) 357 (message "Normalized: %s, regex: %s" normalized-package 358 regexp) 359 (when search-result 360 ;; import-from clause was found 361 t))) 362 363 364 (defun sly-package-fu--create-new-import-from (package symbol) 365 (sly-goto-package-source-definition (sly-current-package)) 366 (forward-sexp) 367 ;; Now, search last :import-from or :use form 368 (cond 369 ((re-search-backward "(:\\(use\\|import-from\\)" nil t) 370 ;; Skip found expression: 371 (forward-sexp) 372 ;; and insert a new (:import-from <package> <symbol>) form. 373 (newline-and-indent) 374 (let ((symbol-name (sly-format-symbol-for-defpackage symbol)) 375 (package-name (sly-format-symbol-for-defpackage package))) 376 (insert "(:import-from )") 377 (backward-char) 378 (insert package-name) 379 (newline-and-indent) 380 (insert symbol-name))) 381 (t (error "Unable to find :use form in the defpackage form.")))) 382 383 384 (defun sly-package-fu--add-or-update-import-from-form (symbol) 385 "Do the heavy-lifting for `sly-import-symbol-at-point'. 386 387 Accept a string or a symbol like \"alexandria:with-gensyms\", 388 and add it to existing (import-from #:alexandria ...) form, or 389 create a new one. Return name of the given symbol inside of its 390 package. For example above, return \"with-gensyms\"." 391 (save-excursion 392 ;; First, will go to the package definition 393 (sly-goto-package-source-definition (sly-current-package)) 394 395 (let* ((package (funcall sly-import-symbol-package-transform-function 396 (sly-cl-symbol-package symbol))) 397 (simple-symbol (sly-cl-symbol-name symbol)) 398 (import-exists (when package 399 (sly-package-fu--search-import-from package)))) 400 401 ;; We only process symbols in fully qualified form like 402 ;; weblocks/request:get-parameter 403 (unless package 404 (user-error "This only works on symbols with package designator.")) 405 406 ;; First ask CL to actually import the symbol (a synchronized 407 ;; eval makes sure that an error aborts the rest of the command) 408 ;; 409 (sly-eval `(slynk:import-symbol-for-emacs ,symbol 410 ,(sly-current-package) 411 ,package)) 412 413 (if import-exists 414 (let ((imported-symbols (mapcar #'sly-package-fu--normalize-name 415 (sly-package-fu--read-symbols)))) 416 (unless (cl-member simple-symbol 417 imported-symbols 418 :test 'cl-equalp) 419 ;; If symbol is not imported yet, then just 420 ;; add it to the end 421 (sly-package-fu--insert-symbol simple-symbol) 422 (when sly-package-fu-save-file (save-buffer)))) 423 ;; If there is no import from this package yet, 424 ;; then we'll add it right after the last :import-from 425 ;; or :use construction 426 (sly-package-fu--create-new-import-from package 427 simple-symbol) 428 (when sly-package-fu-save-file (save-buffer))) 429 ;; Always return symbol-without-package, because it is useful 430 ;; to replace symbol at point and change it from fully qualified 431 ;; form to a simple-form 432 simple-symbol))) 433 434 435 (defun sly-import-symbol-at-point () 436 "Add a qualified symbol to package's :import-from subclause. 437 438 Takes a package-qualified symbol at point, adds it to the current 439 package's defpackage form (under its :import-form subclause) and 440 replaces with a symbol name without the package designator." 441 (interactive) 442 (let* ((bounds (sly-bounds-of-symbol-at-point)) 443 (beg (set-marker (make-marker) (car bounds))) 444 (end (set-marker (make-marker) (cdr bounds)))) 445 (when bounds 446 (let ((non-qualified-name 447 (sly-package-fu--add-or-update-import-from-form 448 (buffer-substring-no-properties beg end)))) 449 (when non-qualified-name 450 (delete-region beg end) 451 (insert non-qualified-name)))))) 452 453 454 (provide 'sly-package-fu)