sly-package-fu.el (18497B)
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 (when (looking-at "\\s_") (insert " ")))) 290 291 (defun sly-remove-export (symbol-name) 292 ;; Assumes we're inside the beginning of a DEFPACKAGE form. 293 (let ((point)) 294 (while (setq point (sly-search-exports-in-defpackage symbol-name)) 295 (save-excursion 296 (goto-char point) 297 (backward-sexp) 298 (delete-region (point) point) 299 (beginning-of-line) 300 (when (looking-at "^\\s-*$") 301 (join-line) 302 (delete-trailing-whitespace (point) (line-end-position))))))) 303 304 (defun sly-export-symbol-at-point () 305 "Add the symbol at point to the defpackage source definition 306 belonging to the current buffer-package. With prefix-arg, remove 307 the symbol again. Additionally performs an EXPORT/UNEXPORT of the 308 symbol in the Lisp image if possible." 309 (interactive) 310 (let* ((symbol (sly-symbol-at-point)) 311 (package (or (and (string-match "^\\([^:]+\\):.*" symbol) 312 (match-string 1 symbol)) 313 (sly-current-package)))) 314 (unless symbol (error "No symbol at point.")) 315 (cond (current-prefix-arg 316 (let* ((attempt (sly-frob-defpackage-form package :unexport symbol)) 317 (howmany (car attempt)) 318 (where (buffer-file-name (cdr attempt)))) 319 (if (cl-plusp howmany) 320 (sly-message "Symbol `%s' no longer exported from `%s' in %s" 321 symbol package where) 322 (sly-message "Symbol `%s' is not exported from `%s' in %s" 323 symbol package where))) 324 (sly-unexport-symbol symbol package)) 325 (t 326 (let* ((attempt (sly-frob-defpackage-form package :export symbol)) 327 (howmany (car attempt)) 328 (where (buffer-file-name (cdr attempt)))) 329 (if (cl-plusp howmany) 330 (sly-message "Symbol `%s' now exported from `%s' in %s" 331 symbol package where) 332 (sly-message "Symbol `%s' already exported from `%s' in %s" 333 symbol package where))) 334 (sly-export-symbol symbol package))))) 335 336 (defun sly-export-class (name) 337 "Export acessors, constructors, etc. associated with a structure or a class" 338 (interactive (list (sly-read-from-minibuffer "Export structure named: " 339 (sly-symbol-at-point)))) 340 (let* ((package (sly-current-package)) 341 (symbols (sly-eval `(slynk:export-structure ,name ,package)))) 342 (sly-message "%s symbols exported from `%s'" 343 (car (sly-frob-defpackage-form package :export symbols)) 344 package))) 345 346 (defalias 'sly-export-structure 'sly-export-class) 347 348 ;; 349 ;; Dealing with import-from 350 ;; 351 352 (defun sly-package-fu--search-import-from (package) 353 (let* ((normalized-package (sly-package-fu--normalize-name package)) 354 (regexp (format "(:import-from[ \t']*\\(:\\|#:\\)?%s" 355 (regexp-quote normalized-package)))) 356 (re-search-forward regexp nil t))) 357 358 359 (defun sly-package-fu--create-new-import-from (package symbol) 360 "Add new :IMPORT-FROM subform for PACKAGE. Add SYMBOL. 361 Assumes point just before start of DEFPACKAGE form" 362 (forward-sexp) 363 ;; Now, search last :import-from or :use form 364 (cond 365 ((or (re-search-backward "(:\\(use\\|import-from\\)" nil t) 366 (and (re-search-backward "def[[:alnum:]]*package" nil t) 367 (progn (forward-sexp) t))) 368 ;; Skip found expression 369 (forward-sexp) 370 ;; and insert a new (:import-from <package> <symbol>) form. 371 (newline-and-indent) 372 (let ((symbol-name (sly-format-symbol-for-defpackage symbol)) 373 (package-name (sly-format-symbol-for-defpackage package))) 374 (insert "(:import-from )") 375 (backward-char) 376 (insert package-name) 377 (newline-and-indent) 378 (insert symbol-name))) 379 (t (error "Can't find suitable place for :import-from defpackage form.")))) 380 381 382 (defun sly-package-fu--add-or-update-import-from-form (symbol) 383 "Do the heavy-lifting for `sly-import-symbol-at-point'. 384 385 Accept a string or a symbol like \"alexandria:with-gensyms\", 386 and add it to existing (import-from #:alexandria ...) form, or 387 create a new one. Return name of the given symbol inside of its 388 package. For example above, return \"with-gensyms\"." 389 (let* ((package (or (funcall sly-import-symbol-package-transform-function 390 (sly-cl-symbol-package symbol)) 391 ;; We only process symbols in fully qualified form like 392 ;; weblocks/request:get-parameter 393 (user-error "`%s' is not a package-qualified symbol." 394 symbol))) 395 (simple-symbol (sly-cl-symbol-name symbol))) 396 (save-excursion 397 ;; First go to just before relevant DEFPACKAGE form 398 ;; 399 (sly-goto-package-source-definition (sly-current-package)) 400 401 ;; Ask CL to actually import the symbol (a synchronized eval 402 ;; makes sure an error aborts the rest of the command) 403 ;; 404 (sly-eval `(slynk:import-symbol-for-emacs ,symbol 405 ,(sly-current-package) 406 ,package)) 407 (if (sly-package-fu--search-import-from package) 408 ;; If specific (:IMPORT-FROM PACKAGE... ) subform exists, 409 ;; attempt to insert package-less SYMBOL there. 410 (let ((imported-symbols (mapcar #'sly-package-fu--normalize-name 411 (sly-package-fu--read-symbols)))) 412 (unless (cl-member simple-symbol 413 imported-symbols 414 :test 'cl-equalp) 415 (sly-package-fu--insert-symbol simple-symbol) 416 (when sly-package-fu-save-file (save-buffer)))) 417 ;; Else, point is unmoved. Add a new (:IMPORT-FROM PACKAGE) 418 ;; subform after any other existing :IMPORT-FROM or :USE 419 ;; subforms. 420 (sly-package-fu--create-new-import-from package 421 simple-symbol) 422 (when sly-package-fu-save-file (save-buffer))) 423 ;; Always return symbol-without-package, because it is useful 424 ;; to replace symbol at point and change it from fully qualified 425 ;; form to a simple-form 426 simple-symbol))) 427 428 429 (defun sly-import-symbol-at-point () 430 "Add a qualified symbol to package's :import-from subclause. 431 432 Takes a package-qualified symbol at point, adds it to the current 433 package's defpackage form (under its :import-form subclause) and 434 replaces with a symbol name without the package designator." 435 (interactive) 436 (let* ((bounds (sly-bounds-of-symbol-at-point)) 437 (beg (set-marker (make-marker) (car bounds))) 438 (end (set-marker (make-marker) (cdr bounds)))) 439 (when bounds 440 (let ((non-qualified-name 441 (sly-package-fu--add-or-update-import-from-form 442 (buffer-substring-no-properties beg end)))) 443 (when non-qualified-name 444 (delete-region beg end) 445 (insert non-qualified-name)))))) 446 447 448 (provide 'sly-package-fu)