Skip to content

Instantly share code, notes, and snippets.

@mmontone

mmontone/cider-utils.el

Last active September 14, 2022 21:24
Show Gist options
  • Save mmontone/be2db16472ae6074fee5a0e543c04c8c to your computer and use it in GitHub Desktop.
Save mmontone/be2db16472ae6074fee5a0e543c04c8c to your computer and use it in GitHub Desktop.
Download ZIP
Emacs utils
Raw
cider-utils.el
(require 'cider)
(require 's)
;; Browse namespace from info -*- lexical-binding: t -*-
(defun cider-docview-render-info (buffer info)
"Emit into BUFFER formatted INFO for the Clojure or Java symbol."
(let* ((ns (nrepl-dict-get info "ns"))
(name (nrepl-dict-get info "name"))
(added (nrepl-dict-get info "added"))
(depr (nrepl-dict-get info "deprecated"))
(macro (nrepl-dict-get info "macro"))
(special (nrepl-dict-get info "special-form"))
(builtin (nrepl-dict-get info "built-in")) ;; babashka specific
(forms (when-let* ((str (nrepl-dict-get info "forms-str")))
(split-string str "\n")))
(args (when-let* ((str (nrepl-dict-get info "arglists-str")))
(split-string str "\n")))
(doc (or (nrepl-dict-get info "doc")
"Not documented."))
(url (nrepl-dict-get info "url"))
(class (nrepl-dict-get info "class"))
(member (nrepl-dict-get info "member"))
(javadoc (nrepl-dict-get info "javadoc"))
(super (nrepl-dict-get info "super"))
(ifaces (nrepl-dict-get info "interfaces"))
(spec (nrepl-dict-get info "spec"))
(clj-name (if ns (concat ns "/" name) name))
(java-name (if member (concat class "/" member) class))
(see-also (nrepl-dict-get info "see-also")))
(cider--help-setup-xref (list #'cider-doc-lookup (format "%s/%s" ns name)) nil buffer)
(with-current-buffer buffer
(cl-flet ((emit (text &optional face)
(insert (if face
(propertize text 'font-lock-face face)
text)
"\n")))
(emit (if class java-name clj-name) 'font-lock-function-name-face)
(when super
(emit (concat " Extends: " (cider-font-lock-as 'java-mode super))))
(when ifaces
(emit (concat "Implements: " (cider-font-lock-as 'java-mode (car ifaces))))
(dolist (iface (cdr ifaces))
(emit (concat " "(cider-font-lock-as 'java-mode iface)))))
(when (or super ifaces)
(insert "\n"))
(when-let* ((forms (or forms args)))
(dolist (form forms)
(insert " ")
(emit (cider-font-lock-as-clojure form))))
(when special
(emit "Special Form" 'font-lock-keyword-face))
(when macro
(emit "Macro" 'font-lock-variable-name-face))
(when builtin
(emit "Built-in" 'font-lock-keyword-face))
(when added
(emit (concat "Added in " added) 'font-lock-comment-face))
(when depr
(emit (concat "Deprecated in " depr) 'font-lock-keyword-face))
(if class
(cider-docview-render-java-doc (current-buffer) doc)
(emit (concat " " doc)))
(when url
(insert "\n Please see ")
(insert-text-button url
'url url
'follow-link t
'action (lambda (x)
(browse-url (button-get x 'url))))
(insert "\n"))
(when javadoc
(insert "\n\nFor additional documentation, see the ")
(insert-text-button "Javadoc"
'url javadoc
'follow-link t
'action (lambda (x)
(browse-url (button-get x 'url))))
(insert ".\n"))
(insert "\n")
(when spec
(emit "Spec:" 'font-lock-function-name-face)
(insert (cider-browse-spec--pprint-indented spec))
(insert "\n\n")
(insert-text-button "Browse spec"
'follow-link t
'action (lambda (_)
(cider-browse-spec (format "%s/%s" ns name))))
(insert "\n\n"))
(if (and cider-docview-file (not (string= cider-docview-file "")))
(progn
(insert (propertize (if class java-name clj-name)
'font-lock-face 'font-lock-function-name-face)
" is defined in ")
(insert-text-button (cider--abbreviate-file-protocol cider-docview-file)
'follow-link t
'action (lambda (_x)
(cider-docview-source)))
(insert "."))
(insert "Definition location unavailable."))
(when see-also
(insert "\n\n Also see: ")
(mapc (lambda (ns-sym)
(let* ((ns-sym-split (split-string ns-sym "/"))
(see-also-ns (car ns-sym-split))
(see-also-sym (cadr ns-sym-split))
;; if the var belongs to the same namespace,
;; we omit the namespace to save some screen space
(symbol (if (equal ns see-also-ns) see-also-sym ns-sym)))
(insert-text-button symbol
'type 'help-xref
'help-function (apply-partially #'cider-doc-lookup symbol)))
(insert " "))
see-also))
;; Mariano's custom:
(when ns
(newline 2)
(insert "in namespace: ")
(insert-text-button ns
'follow-link t
'action (lambda (_)
(cider-browse-ns ns))))
(cider--doc-make-xrefs)
(let ((beg (point-min))
(end (point-max)))
(nrepl-dict-map (lambda (k v)
(put-text-property beg end k v))
info)))
(current-buffer))))
(defun cider--parse-completion (completion)
(list :doc (nth 2 completion)
:type (nth 6 completion)
:name (nth 4 completion)))
(defun cider-complete-apropos (query)
(interactive "sComplete apropos: ")
(let ((completions (mapcar #'cider--parse-completion (cider-sync-request:apropos query))))
(cl-flet ((describe-completion (completion-name)
(let ((completion (find-if (lambda (c) (string= (getf c :name) completion-name)) completions)))
(format " -- %s" (cl-getf completion :doc)))))
(let ((completion-extra-properties (list :annotation-function #'describe-completion)))
(let ((completion (completing-read (format "%s: " query)
(mapcar (lambda (completion)
(getf completion :name))
completions))))
(insert completion))))))
(defun cider-browse-ns--render-buffer (&optional buffer)
"Render the sections of the browse-ns buffer.
Render occurs in BUFFER if non-nil. This function is the main entrypoint
for redisplaying the buffer when filters change."
(with-current-buffer (or buffer (current-buffer))
(let* ((inhibit-read-only t)
(point (point))
(filtered-items (nrepl-dict-filter #'cider-browse-ns--item-filter
cider-browse-ns-items))
(filtered-item-ct (- (length (nrepl-dict-keys cider-browse-ns-items))
(length (nrepl-dict-keys filtered-items)))))
(erase-buffer)
(insert (propertize (cider-propertize cider-browse-ns-title 'ns) 'ns t) "\n")
(when cider-browse-ns-current-ns
;; By Mariano: insert namespace docs
(insert (car (read-from-string (nrepl-dict-get
(cider-nrepl-sync-request:eval
(format "(with-out-str (clojure.repl/doc %s))" cider-browse-ns-current-ns))
"value"))))
(newline)
(insert "---------------------------")
(newline 2)
(cider-browse-ns--render-header filtered-item-ct))
(cider-browse-ns--render-items filtered-items)
(goto-char point))))
(defun cider-display-error-message (message eval-buffer)
(message message))
(defun cider-handle-compilation-errors (message eval-buffer)
"Highlight and jump to compilation error extracted from MESSAGE.
EVAL-BUFFER is the buffer that was current during user's interactive
evaluation command. Honor `cider-auto-jump-to-error'."
(message message)
(when-let* ((loc (cider--find-last-error-location message))
(overlay (make-overlay (nth 0 loc) (nth 1 loc) (nth 2 loc)))
(info (cider-extract-error-info cider-compilation-regexp message)))
(let* ((face (nth 3 info))
(note (nth 4 info))
(auto-jump (if (eq cider-auto-jump-to-error 'errors-only)
(not (or (eq face 'cider-warning-highlight-face)
(string-match-p "warning" note)))
cider-auto-jump-to-error)))
(overlay-put overlay 'cider-note-p t)
(overlay-put overlay 'font-lock-face face)
(overlay-put overlay 'cider-note note)
(overlay-put overlay 'help-echo note)
(overlay-put overlay 'modification-hooks
(list (lambda (o &rest _args) (delete-overlay o))))
(when auto-jump
(with-current-buffer eval-buffer
(push-mark)
;; At this stage selected window commonly is *cider-error* and we need to
;; re-select the original user window. If eval-buffer is not
;; visible it was probably covered as a result of a small screen or user
;; configuration (https://github.com/clojure-emacs/cider/issues/847). In
;; that case we don't jump at all in order to avoid covering *cider-error*
;; buffer.
(when-let* ((win (get-buffer-window eval-buffer)))
(with-selected-window win
(cider-jump-to (nth 2 loc) (car loc)))))))))
(advice-add 'cider-display-error-message :before #'cider-handle-compilation-errors)
;; ---------- Clojure inspector ---------------------
(defun cider-clj-inspector-inspect-last-result ()
(interactive)
;; How to propagate prefix arg?
(cider-clj-inspector-inspect "*1"))
(defun cider-clj-inspector-inspect-table (&optional expr)
(interactive)
(cider-nrepl-request:eval (format "(clojure.inspector/inspect-table %s)"
(or expr (cider-last-sexp)))
(lambda (&rest args))))
(defun cider-clj-inspector-inspect-tree (&optional expr)
(interactive)
(cider-nrepl-request:eval (format "(clojure.inspector/inspect-tree %s)"
(or expr (cider-last-sexp)))
(lambda (&rest args))))
(defun cider-clj-inspector-inspect (&optional expr inspector-type)
(interactive
(list
;; Expression
nil
;; Inspector type
(and current-prefix-arg
(completing-read "Inspector type: "
(list "Vanilla" "Tree" "Table")))))
(when (null expr)
(setq expr (cider-last-sexp)))
(cond
((or (null inspector-type) (string= inspector-type "Vanilla"))
(cider-nrepl-request:eval (format "(clojure.inspector/inspect %s)" expr)
(lambda (&rest args))))
((string= inspector-type "Tree")
(cider-clj-inspector-inspect-tree expr))
((string= inspector-type "Table")
(cider-clj-inspector-inspect-table expr))))
;; Docstring in eldoc minibuffer
(defun cider-eldoc-format-function (thing pos eldoc-info)
"Return the formatted eldoc string for a function.
THING is the function name. POS is the argument-index of the functions
arglists. ELDOC-INFO is a p-list containing the eldoc information."
(let ((ns (lax-plist-get eldoc-info "ns"))
(symbol (lax-plist-get eldoc-info "symbol"))
(arglists (lax-plist-get eldoc-info "arglists"))
(docstring (lax-plist-get eldoc-info "docstring")))
(format "%s: %s%s"
(cider-eldoc-format-thing ns symbol thing 'fn)
(cider-eldoc-format-arglist arglists pos)
(if (null docstring)
""
(let ((end (or (aand (position ?. docstring)
(1+ it))
(1- (length docstring)))))
(format " - %s" (s-replace "\n" " " (cl-subseq docstring 0 end))))))))
Raw
emacs-utils.el
(defun indent-buffer ()
"indent whole buffer"
(interactive)
(delete-trailing-whitespace)
(indent-region (point-min) (point-max) nil)
(untabify (point-min) (point-max)))
(defun slime-info-apropos (symbol-name)
(interactive (list (slime-read-symbol-name "Apropos symbol info: ")))
(when (not symbol-name)
(error "No symbol given"))
(if (position 58 symbol-name) ;; 58 is the colon character
(info-apropos symbol-name)
(let* ((symbol-package-name
(slime-eval
`(cl:package-name
(cl:symbol-package (cl:read-from-string ,(concat (remove 58 (slime-current-package)) "::" symbol-name))))))
(index-entry (concat symbol-package-name ":" symbol-name)))
(info-apropos index-entry))))
(defun apropos-package--filter (string)
(let (packages)
(dolist (package-assoc package-archive-contents)
(let ((package (cadr package-assoc)))
(when (or (string-match-p (regexp-quote string) (package-desc-summary package))
(string-match-p (regexp-quote string) (prin1-to-string (package-desc-name package))))
(push package packages))))
packages))
(defun apropos-package (string)
(interactive "sSearch for package: ")
;; Initialize the package system if necessary.
(unless package--initialized
(package-initialize t))
(let ((packages (apropos-package--filter string)))
(if (null packages)
(message "No packages")
(package-show-package-list (mapcar 'package-desc-name packages)))))
(defun what-overlays ()
"List overlays at current cursor position."
(interactive)
(message (prin1-to-string (overlays-at (point)))))
(defun eval-last-sexp-and-insert ()
(interactive)
(let ((result (eval-last-sexp)))
(with-current-buffer (current-buffer)
(insert (prin1-to-string result)))))
(defun elisp-eldoc-documentation-function ()
"`eldoc-documentation-function' (which see) for Emacs Lisp.
Replace default elisp-eldoc documentation function to display docstrings for functions too."
(let ((current-symbol (elisp--current-symbol))
(current-fnsym (elisp--fnsym-in-current-sexp)))
(cond ((null current-fnsym)
nil)
((eq current-symbol (car current-fnsym))
(or (concat (apply #'elisp-get-fnsym-args-string current-fnsym)
(or (and (or (functionp (car current-fnsym))
(macrop (car current-fnsym)))
(concat ". "
(elisp--docstring-first-line (documentation (car current-fnsym)))))
""))
(elisp-get-var-docstring current-symbol)))
(t
(or (elisp-get-var-docstring current-symbol)
(concat (apply #'elisp-get-fnsym-args-string current-fnsym)
(or (and (or (functionp (car current-fnsym))
(macrop (car current-fnsym)))
(concat ". "
(elisp--docstring-first-line (documentation (car current-fnsym)))))
"")))))))
(defun fix-elisp-cl-deprecations ()
(interactive)
(replace-string "(defun*" "(cl-defun")
(replace-string "(return-from" "(cl-return-from")
(replace-string "(subseq" "(cl-subseq")
(replace-string "(getf" "(cl-getf")
(replace-string "(destructuring-bind" "(cl-destructuring-bind")
(replace-string "(remove-if-not" "(cl-remove-if-not")
(replace-string "(remove-if" "(cl-remove-if")
(replace-string "(find-if" "(cl-find-if")
(replace-string "(copy-list" "(cl-copy-list")
(replace-string "(position" "(cl-position")
(replace-string "(some" "(cl-some"))
(defun easy-routes-show-tree ()
(interactive)
(let ((tree
(slime-eval '(cl:with-output-to-string (cl:*standard-output*)
(cl:describe easy-routes:*routes-mapper*)))))
(let ((buffer (get-buffer-create "*easy-routes*")))
(with-current-buffer buffer
(insert tree)
(setq buffer-read-only t)
(slime-mode))
(display-buffer buffer))))
(defun move-file (new-location)
"Write this file to NEW-LOCATION, and delete the old one."
(interactive (list (expand-file-name
(if buffer-file-name
(read-file-name "Move file to: ")
(read-file-name "Move file to: "
default-directory
(expand-file-name (file-name-nondirectory (buffer-name))
default-directory))))))
(when (file-exists-p new-location)
(delete-file new-location))
(let ((old-location (expand-file-name (buffer-file-name))))
(message "old file is %s and new file is %s"
old-location
new-location)
(write-file new-location t)
(when (and old-location
(file-exists-p new-location)
(not (string-equal old-location new-location)))
(delete-file old-location))))
(defun defun-at-point ()
"Return the text of the defun at point."
(apply #'buffer-substring-no-properties
(region-for-defun-at-point)))
(defun region-for-defun-at-point ()
"Return the start and end position of defun at point."
(save-excursion
(save-match-data
(end-of-defun)
(let ((end (point)))
(beginning-of-defun)
(list (point) end)))))
(defun ert-run-test-at-point ()
"Run the ert test at point."
(interactive)
(let* ((test-form (read-from-string (defun-at-point)))
(test-name (cadar test-form)))
(ert test-name)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment