Emacs utils

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))))))))

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)))