;; -*- lexical-binding: t; -*-
(require 'sly)
(require 'sly-parse "lib/sly-parse")
(define-sly-contrib sly-package-fu
"Exporting/Unexporting symbols at point."
(:authors "Tobias C. Rittweiler <tcr@freebits.de>")
(:license "GPL")
(:slynk-dependencies slynk/package-fu)
(:on-load
(define-key sly-mode-map "\C-cx" 'sly-export-symbol-at-point)
(define-key sly-mode-map "\C-ci" 'sly-import-symbol-at-point))
(:on-unload
;; FIXME: To properly support unloading, this contrib should be
;; made a minor mode with it's own keymap. The minor mode
;; activation function should be added to the proper sly-* hooks.
;;
))
(defvar sly-package-file-candidates
(mapcar #'file-name-nondirectory
'("package.lisp" "packages.lisp" "pkgdcl.lisp"
"defpackage.lisp")))
(defvar sly-export-symbol-representation-function
#'(lambda (n) (format "#:%s" n)))
(defvar sly-import-symbol-package-transform-function
'identity
"String transformation used by `sly-import-symbol-at-point'.
This function is applied to a package name before it is inserted
into the defpackage form. By default, it is `identity' but you
may wish redefine it to do some tranformations, for example, to
replace dots with slashes to conform to a package-inferred ASDF
system-definition style.")
(defvar sly-export-symbol-representation-auto t
"Determine automatically which style is used for symbols, #: or :
If it's mixed or no symbols are exported so far,
use `sly-export-symbol-representation-function'.")
(define-obsolete-variable-alias 'sly-export-save-file
'sly-package-fu-save-file "1.0.0-beta-3")
(defvar sly-package-fu-save-file nil
"Save the package file after each automatic modification")
(defvar sly-defpackage-regexp
"^(\\(cl:\\|common-lisp:\\|uiop:\\|\\uiop/package:\\)?\\(defpackage\\|define-package\\)\\>[ \t']*")
(put 'uiop:define-package 'sly-common-lisp-indent-function '(as defpackage))
(defun sly-find-package-definition-rpc (package)
(sly-eval `(slynk:find-definition-for-thing
(slynk::guess-package ,package))))
(defun sly-find-package-definition-regexp (package)
(save-excursion
(save-match-data
(goto-char (point-min))
(cl-block nil
(while (re-search-forward sly-defpackage-regexp nil t)
(when (sly-package-equal package (sly-sexp-at-point))
(backward-sexp)
(cl-return (make-sly-file-location (buffer-file-name)
(1- (point))))))))))
(defun sly-package-equal (designator1 designator2)
;; First try to be lucky and compare the strings themselves (for the
;; case when one of the designated packages isn't loaded in the
;; image.) Then try to do it properly using the inferior Lisp which
;; will also resolve nicknames for us &c.
(or (cl-equalp (sly-cl-symbol-name designator1)
(sly-cl-symbol-name designator2))
(sly-eval `(slynk:package= ,designator1 ,designator2))))
(defun sly-export-symbol (symbol package)
"Unexport `symbol' from `package' in the Lisp image."
(sly-eval `(slynk:export-symbol-for-emacs ,symbol ,package)))
(defun sly-unexport-symbol (symbol package)
"Export `symbol' from `package' in the Lisp image."
(sly-eval `(slynk:unexport-symbol-for-emacs ,symbol ,package)))
(defun sly-find-possible-package-file (buffer-file-name)
(cl-labels ((file-name-subdirectory (dirname)
(expand-file-name
(concat (file-name-as-directory (sly-to-lisp-filename dirname))
(file-name-as-directory ".."))))
(try (dirname)
(cl-dolist (package-file-name sly-package-file-candidates)
(let ((f (sly-to-lisp-filename
(concat dirname package-file-name))))
(when (file-readable-p f)
(cl-return f))))))
(when buffer-file-name
(let ((buffer-cwd (file-name-directory buffer-file-name)))
(or (try buffer-cwd)
(try (file-name-subdirectory buffer-cwd))
(try (file-name-subdirectory
(file-name-subdirectory buffer-cwd))))))))
(defun sly-goto-package-source-definition (package)
"Tries to find the DEFPACKAGE form of `package'. If found,
places the cursor at the start of the DEFPACKAGE form."
(cl-labels ((try (location)
(when (sly-location-p location)
(sly-move-to-source-location location)
t)))
(or (try (sly-find-package-definition-rpc package))
(try (sly-find-package-definition-regexp package))
(try (sly--when-let
(package-file (sly-find-possible-package-file
(buffer-file-name)))
(with-current-buffer (find-file-noselect package-file t)
(sly-find-package-definition-regexp package))))
(sly-error "Couldn't find source definition of package: %s" package))))
(defun sly-at-expression-p (pattern)
(when (ignore-errors
;; at a list?
(= (point) (progn (down-list 1)
(backward-up-list 1)
(point))))
(save-excursion
(down-list 1)
(sly-in-expression-p pattern))))
(defun sly-goto-next-export-clause ()
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(let ((point))
(save-excursion
(cl-block nil
(while (ignore-errors (sly-forward-sexp) t)
(skip-chars-forward " \n\t")
(when (sly-at-expression-p '(:export *))
(setq point (point))
(cl-return)))))
(if point
(goto-char point)
(error "No next (:export ...) clause found"))))
(defun sly-search-exports-in-defpackage (symbol-name)
"Look if `symbol-name' is mentioned in one of the :EXPORT clauses."
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(cl-labels ((target-symbol-p (symbol)
(string-match-p (format "^\\(\\(#:\\)\\|:\\)?%s$"
(regexp-quote symbol-name))
symbol)))
(save-excursion
(cl-block nil
(while (ignore-errors (sly-goto-next-export-clause) t)
(let ((clause-end (save-excursion (forward-sexp) (point))))
(save-excursion
(while (search-forward symbol-name clause-end t)
(when (target-symbol-p (sly-symbol-at-point))
(cl-return (if (sly-inside-string-p)
;; Include the following "
(1+ (point))
(point))))))))))))
(defun sly-package-fu--read-symbols ()
"Reads sexps as strings from the point to end of sexp.
For example, in this situation.
(for<point> bar minor (again 123))
this will return (\"bar\" \"minor\" \"(again 123)\")"
(cl-labels ((read-sexp ()
(ignore-errors
(forward-comment (point-max))
(buffer-substring-no-properties
(point) (progn (forward-sexp) (point))))))
(save-excursion
(cl-loop for sexp = (read-sexp) while sexp collect sexp))))
(defun sly-package-fu--normalize-name (name)
(if (string-prefix-p "\"" name)
(read name)
(replace-regexp-in-string "^\\(\\(#:\\)\\|:\\)"
"" name)))
(defun sly-defpackage-exports ()
"Return a list of symbols inside :export clause of a defpackage."
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(save-excursion
(mapcar #'sly-package-fu--normalize-name
(cl-loop while (ignore-errors (sly-goto-next-export-clause) t)
do (down-list) (forward-sexp)
append (sly-package-fu--read-symbols)
do (up-list) (backward-sexp)))))
(defun sly-symbol-exported-p (name symbols)
(cl-member name symbols :test 'cl-equalp))
(defun sly-frob-defpackage-form (current-package do-what symbols)
"Adds/removes `symbol' from the DEFPACKAGE form of `current-package'
depending on the value of `do-what' which can either be `:export',
or `:unexport'.
Returns t if the symbol was added/removed. Nil if the symbol was
already exported/unexported."
(save-excursion
(sly-goto-package-source-definition current-package)
(down-list 1) ; enter DEFPACKAGE form
(forward-sexp) ; skip DEFPACKAGE symbol
;; Don't or will fail if (:export ...) is immediately following
;; (forward-sexp) ; skip package name
(let ((exported-symbols (sly-defpackage-exports))
(symbols (if (consp symbols)
symbols
(list symbols)))
(number-of-actions 0))
(cl-ecase do-what
(:export
(sly-add-export)
(dolist (symbol symbols)
(let ((symbol-name (sly-cl-symbol-name symbol)))
(unless (sly-symbol-exported-p symbol-name exported-symbols)
(cl-incf number-of-actions)
(sly-package-fu--insert-symbol symbol-name)))))
(:unexport
(dolist (symbol symbols)
(let ((symbol-name (sly-cl-symbol-name symbol)))
(when (sly-symbol-exported-p symbol-name exported-symbols)
(sly-remove-export symbol-name)
(cl-incf number-of-actions))))))
(when sly-package-fu-save-file
(save-buffer))
(cons number-of-actions
(current-buffer)))))
(defun sly-add-export ()
(let (point)
(save-excursion
(while (ignore-errors (sly-goto-next-export-clause) t)
(setq point (point))))
(cond (point
(goto-char point)
(down-list)
(sly-end-of-list))
(t
(sly-end-of-list)
(unless (looking-back "^\\s-*" (line-beginning-position) nil)
(newline-and-indent))
(insert "(:export ")
(save-excursion (insert ")"))))))
(defun sly-determine-symbol-style ()
;; Assumes we're inside :export
(save-excursion
(sly-beginning-of-list)
(sly-forward-sexp)
(let ((symbols (sly-package-fu--read-symbols)))
(cond ((null symbols)
sly-export-symbol-representation-function)
((cl-every (lambda (x)
(string-match "^:" x))
symbols)
(lambda (n) (format ":%s" n)))
((cl-every (lambda (x)
(string-match "^#:" x))
symbols)
(lambda (n) (format "#:%s" n)))
((cl-every (lambda (x)
(string-prefix-p "\"" x))
symbols)
(lambda (n) (prin1-to-string (upcase (substring-no-properties n)))))
(t
sly-export-symbol-representation-function)))))
(defun sly-format-symbol-for-defpackage (symbol-name)
(funcall (if sly-export-symbol-representation-auto
(sly-determine-symbol-style)
sly-export-symbol-representation-function)
symbol-name))
(defun sly-package-fu--insert-symbol (symbol-name)
;; Assumes we're at the inside :export or :import-from form
;; after the last symbol
(let ((symbol-name (sly-format-symbol-for-defpackage symbol-name)))
(unless (looking-back "^\\s-*" (line-beginning-position) nil)
(newline-and-indent))
(insert symbol-name)))
(defun sly-remove-export (symbol-name)
;; Assumes we're inside the beginning of a DEFPACKAGE form.
(let ((point))
(while (setq point (sly-search-exports-in-defpackage symbol-name))
(save-excursion
(goto-char point)
(backward-sexp)
(delete-region (point) point)
(beginning-of-line)
(when (looking-at "^\\s-*$")
(join-line)
(delete-trailing-whitespace (point) (line-end-position)))))))
(defun sly-export-symbol-at-point ()
"Add the symbol at point to the defpackage source definition
belonging to the current buffer-package. With prefix-arg, remove
the symbol again. Additionally performs an EXPORT/UNEXPORT of the
symbol in the Lisp image if possible."
(interactive)
(let* ((symbol (sly-symbol-at-point))
(package (or (and (string-match "^\\([^:]+\\):.*" symbol)
(match-string 1 symbol))
(sly-current-package))))
(unless symbol (error "No symbol at point."))
(cond (current-prefix-arg
(let* ((attempt (sly-frob-defpackage-form package :unexport symbol))
(howmany (car attempt))
(where (buffer-file-name (cdr attempt))))
(if (cl-plusp howmany)
(sly-message "Symbol `%s' no longer exported from `%s' in %s"
symbol package where)
(sly-message "Symbol `%s' is not exported from `%s' in %s"
symbol package where)))
(sly-unexport-symbol symbol package))
(t
(let* ((attempt (sly-frob-defpackage-form package :export symbol))
(howmany (car attempt))
(where (buffer-file-name (cdr attempt))))
(if (cl-plusp howmany)
(sly-message "Symbol `%s' now exported from `%s' in %s"
symbol package where)
(sly-message "Symbol `%s' already exported from `%s' in %s"
symbol package where)))
(sly-export-symbol symbol package)))))
(defun sly-export-class (name)
"Export acessors, constructors, etc. associated with a structure or a class"
(interactive (list (sly-read-from-minibuffer "Export structure named: "
(sly-symbol-at-point))))
(let* ((package (sly-current-package))
(symbols (sly-eval `(slynk:export-structure ,name ,package))))
(sly-message "%s symbols exported from `%s'"
(car (sly-frob-defpackage-form package :export symbols))
package)))
(defalias 'sly-export-structure 'sly-export-class)
;;
;; Dealing with import-from
;;
(defun sly-package-fu--search-import-from (package)
;; Suppose, we are in the defpackage sexp
(let* ((normalized-package (sly-package-fu--normalize-name package))
(regexp (format "(:import-from[ \t']*\\(:\\|#:\\)?%s"
(regexp-quote (regexp-quote normalized-package))))
(search-result (re-search-forward regexp nil t)))
(message "Normalized: %s, regex: %s" normalized-package
regexp)
(when search-result
;; import-from clause was found
t)))
(defun sly-package-fu--create-new-import-from (package symbol)
(sly-goto-package-source-definition (sly-current-package))
(forward-sexp)
;; Now, search last :import-from or :use form
(cond
((re-search-backward "(:\\(use\\|import-from\\)" nil t)
;; Skip found expression:
(forward-sexp)
;; and insert a new (:import-from <package> <symbol>) form.
(newline-and-indent)
(let ((symbol-name (sly-format-symbol-for-defpackage symbol))
(package-name (sly-format-symbol-for-defpackage package)))
(insert "(:import-from )")
(backward-char)
(insert package-name)
(newline-and-indent)
(insert symbol-name)))
(t (error "Unable to find :use form in the defpackage form."))))
(defun sly-package-fu--add-or-update-import-from-form (symbol)
"Do the heavy-lifting for `sly-import-symbol-at-point'.
Accept a string or a symbol like \"alexandria:with-gensyms\",
and add it to existing (import-from #:alexandria ...) form, or
create a new one. Return name of the given symbol inside of its
package. For example above, return \"with-gensyms\"."
(save-excursion
;; First, will go to the package definition
(sly-goto-package-source-definition (sly-current-package))
(let* ((package (funcall sly-import-symbol-package-transform-function
(sly-cl-symbol-package symbol)))
(simple-symbol (sly-cl-symbol-name symbol))
(import-exists (when package
(sly-package-fu--search-import-from package))))
;; We only process symbols in fully qualified form like
;; weblocks/request:get-parameter
(unless package
(user-error "This only works on symbols with package designator."))
;; First ask CL to actually import the symbol (a synchronized
;; eval makes sure that an error aborts the rest of the command)
;;
(sly-eval `(slynk:import-symbol-for-emacs ,symbol
,(sly-current-package)
,package))
(if import-exists
(let ((imported-symbols (mapcar #'sly-package-fu--normalize-name
(sly-package-fu--read-symbols))))
(unless (cl-member simple-symbol
imported-symbols
:test 'cl-equalp)
;; If symbol is not imported yet, then just
;; add it to the end
(sly-package-fu--insert-symbol simple-symbol)
(when sly-package-fu-save-file (save-buffer))))
;; If there is no import from this package yet,
;; then we'll add it right after the last :import-from
;; or :use construction
(sly-package-fu--create-new-import-from package
simple-symbol)
(when sly-package-fu-save-file (save-buffer)))
;; Always return symbol-without-package, because it is useful
;; to replace symbol at point and change it from fully qualified
;; form to a simple-form
simple-symbol)))
(defun sly-import-symbol-at-point ()
"Add a qualified symbol to package's :import-from subclause.
Takes a package-qualified symbol at point, adds it to the current
package's defpackage form (under its :import-form subclause) and
replaces with a symbol name without the package designator."
(interactive)
(let* ((bounds (sly-bounds-of-symbol-at-point))
(beg (set-marker (make-marker) (car bounds)))
(end (set-marker (make-marker) (cdr bounds))))
(when bounds
(let ((non-qualified-name
(sly-package-fu--add-or-update-import-from-form
(buffer-substring-no-properties beg end))))
(when non-qualified-name
(delete-region beg end)
(insert non-qualified-name))))))
(provide 'sly-package-fu)