1;;; cider-browse-ns.el --- CIDER namespace browser
2
3;; Copyright © 2014-2021 John Andrews, Bozhidar Batsov and CIDER contributors
4
5;; Author: John Andrews <john.m.andrews@gmail.com>
6
7;; This program is free software: you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation, either version 3 of the License, or
10;; (at your option) any later version.
11
12;; This program is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
19
20;; This file is not part of GNU Emacs.
21
22;;; Commentary:
23
24;; M-x cider-browse-ns
25;;
26;; Display a list of all vars in a namespace.
27;; Pressing <enter> will take you to the cider-doc buffer for that var.
28;; Pressing ^ will take you to a list of all namespaces (akin to `dired-mode').
29
30;; M-x cider-browse-ns-all
31;;
32;; Explore Clojure namespaces by browsing a list of all namespaces.
33;; Pressing <enter> expands into a list of that namespace's vars as if by
34;; executing the command (cider-browse-ns "my.ns").
35
36;;; Code:
37
38(require 'cider-client)
39(require 'cider-popup)
40(require 'cider-compat)
41(require 'cider-util)
42(require 'nrepl-dict)
43
44(require 'subr-x)
45(require 'easymenu)
46(require 'thingatpt)
47
48(defconst cider-browse-ns-buffer "*cider-ns-browser*")
49
50(defvar-local cider-browse-ns-current-ns nil)
51
52;; Mode Definition
53
54(defvar cider-browse-ns-mode-map
55  (let ((map (make-sparse-keymap)))
56    (set-keymap-parent map cider-popup-buffer-mode-map)
57    (define-key map "d" #'cider-browse-ns-doc-at-point)
58    (define-key map "s" #'cider-browse-ns-find-at-point)
59    (define-key map (kbd "RET") #'cider-browse-ns-operate-at-point)
60    (define-key map "^" #'cider-browse-ns-all)
61    (define-key map "n" #'next-line)
62    (define-key map "p" #'previous-line)
63    (easy-menu-define cider-browse-ns-mode-menu map
64      "Menu for CIDER's namespace browser"
65      '("Namespace Browser"
66        ["Show doc" cider-browse-ns-doc-at-point]
67        ["Go to definition" cider-browse-ns-find-at-point]
68        "--"
69        ["Browse all namespaces" cider-browse-ns-all]))
70    map))
71
72(defvar cider-browse-ns-mouse-map
73  (let ((map (make-sparse-keymap)))
74    (define-key map [mouse-1] #'cider-browse-ns-handle-mouse)
75    map))
76
77(define-derived-mode cider-browse-ns-mode special-mode "browse-ns"
78  "Major mode for browsing Clojure namespaces.
79
80\\{cider-browse-ns-mode-map}"
81  (setq-local electric-indent-chars nil)
82  (setq-local sesman-system 'CIDER)
83  (when cider-special-mode-truncate-lines
84    (setq-local truncate-lines t))
85  (setq-local cider-browse-ns-current-ns nil))
86
87(defun cider-browse-ns--text-face (var-meta)
88  "Return font-lock-face for a var.
89VAR-META contains the metadata information used to decide a face.
90Presence of \"arglists\" and \"macro\" indicates a macro form.
91Only \"arglists\" indicates a function. Otherwise, its a variable.
92If the NAMESPACE is not loaded in the REPL, assume TEXT is a fn."
93  (cond
94   ((not var-meta) 'font-lock-function-name-face)
95   ((and (nrepl-dict-contains var-meta "arglists")
96         (string= (nrepl-dict-get var-meta "macro") "true"))
97    'font-lock-keyword-face)
98   ((nrepl-dict-contains var-meta "arglists") 'font-lock-function-name-face)
99   (t 'font-lock-variable-name-face)))
100
101(defun cider-browse-ns--properties (var var-meta)
102  "Decorate VAR with a clickable keymap and a face.
103VAR-META is used to decide a font-lock face."
104  (let ((face (cider-browse-ns--text-face var-meta)))
105    (propertize var
106                'font-lock-face face
107                'mouse-face 'highlight
108                'keymap cider-browse-ns-mouse-map)))
109
110(defun cider-browse-ns--list (buffer title items &optional ns noerase)
111  "Reset contents of BUFFER.
112Display TITLE at the top and ITEMS are indented underneath.
113If NS is non-nil, it is added to each item as the
114`cider-browse-ns-current-ns' text property.  If NOERASE is non-nil, the
115contents of the buffer are not reset before inserting TITLE and ITEMS."
116  (with-current-buffer buffer
117    (cider-browse-ns-mode)
118    (let ((inhibit-read-only t))
119      (unless noerase (erase-buffer))
120      (goto-char (point-max))
121      (insert (cider-propertize title 'ns) "\n")
122      (dolist (item items)
123        (insert (propertize (concat "  " item "\n")
124                            'cider-browse-ns-current-ns ns)))
125      (goto-char (point-min)))))
126
127(defun cider-browse-ns--first-doc-line (doc)
128  "Return the first line of the given DOC string.
129If the first line of the DOC string contains multiple sentences, only
130the first sentence is returned.  If the DOC string is nil, a Not documented
131string is returned."
132  (if doc
133      (let* ((split-newline (split-string doc "\n"))
134             (first-line (car split-newline)))
135        (cond
136         ((string-match "\\. " first-line) (substring first-line 0 (match-end 0)))
137         ((= 1 (length split-newline)) first-line)
138         (t (concat first-line "..."))))
139    "Not documented."))
140
141(defun cider-browse-ns--items (namespace)
142  "Return the items to show in the namespace browser of the given NAMESPACE.
143Each item consists of a ns-var and the first line of its docstring."
144  (let* ((ns-vars-with-meta (cider-sync-request:ns-vars-with-meta namespace))
145         (propertized-ns-vars (nrepl-dict-map #'cider-browse-ns--properties ns-vars-with-meta)))
146    (mapcar (lambda (ns-var)
147              (let* ((doc (nrepl-dict-get-in ns-vars-with-meta (list ns-var "doc")))
148                     ;; to avoid (read nil)
149                     ;; it prompts the user for a Lisp expression
150                     (doc (when doc (read doc)))
151                     (first-doc-line (cider-browse-ns--first-doc-line doc)))
152                (concat ns-var " " (propertize first-doc-line 'font-lock-face 'font-lock-doc-face))))
153            propertized-ns-vars)))
154
155;; Interactive Functions
156
157;;;###autoload
158(defun cider-browse-ns (namespace)
159  "List all NAMESPACE's vars in BUFFER."
160  (interactive (list (completing-read "Browse namespace: " (cider-sync-request:ns-list))))
161  (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer 'select nil 'ancillary)
162    (cider-browse-ns--list (current-buffer)
163                           namespace
164                           (cider-browse-ns--items namespace))
165    (setq-local cider-browse-ns-current-ns namespace)))
166
167;;;###autoload
168(defun cider-browse-ns-all ()
169  "List all loaded namespaces in BUFFER."
170  (interactive)
171  (with-current-buffer (cider-popup-buffer cider-browse-ns-buffer 'select nil 'ancillary)
172    (let ((names (cider-sync-request:ns-list)))
173      (cider-browse-ns--list (current-buffer)
174                             "All loaded namespaces"
175                             (mapcar (lambda (name)
176                                       (cider-browse-ns--properties name nil))
177                                     names))
178      (setq-local cider-browse-ns-current-ns nil))))
179
180(defun cider-browse-ns--thing-at-point ()
181  "Get the thing at point.
182Return a list of the type ('ns or 'var) and the value."
183  (let ((line (car (split-string (string-trim (thing-at-point 'line)) " "))))
184    (if (string-match "\\." line)
185        `(ns ,line)
186      `(var ,(format "%s/%s"
187                     (or (get-text-property (point) 'cider-browse-ns-current-ns)
188                         cider-browse-ns-current-ns)
189                     line)))))
190
191(declare-function cider-doc-lookup "cider-doc")
192
193(defun cider-browse-ns-doc-at-point ()
194  "Show the documentation for the thing at current point."
195  (interactive)
196  (let* ((thing (cider-browse-ns--thing-at-point))
197         (value (cadr thing)))
198    ;; value is either some ns or a var
199    (cider-doc-lookup value)))
200
201(defun cider-browse-ns-operate-at-point ()
202  "Expand browser according to thing at current point.
203If the thing at point is a ns it will be browsed,
204and if the thing at point is some var - its documentation will
205be displayed."
206  (interactive)
207  (let* ((thing (cider-browse-ns--thing-at-point))
208         (type (car thing))
209         (value (cadr thing)))
210    (if (eq type 'ns)
211        (cider-browse-ns value)
212      (cider-doc-lookup value))))
213
214(declare-function cider-find-ns "cider-find")
215(declare-function cider-find-var "cider-find")
216
217(defun cider-browse-ns-find-at-point ()
218  "Find the definition of the thing at point."
219  (interactive)
220  (let* ((thing (cider-browse-ns--thing-at-point))
221         (type (car thing))
222         (value (cadr thing)))
223    (if (eq type 'ns)
224        (cider-find-ns nil value)
225      (cider-find-var current-prefix-arg value))))
226
227(defun cider-browse-ns-handle-mouse (event)
228  "Handle mouse click EVENT."
229  (interactive "e")
230  (cider-browse-ns-operate-at-point))
231
232(provide 'cider-browse-ns)
233
234;;; cider-browse-ns.el ends here
235