Add cider-browse-spec-all and cider-browse-spec implementation

CHANGELOG.md

@@ -3,7 +3,7 @@
 ## master (unreleased)
 
 ### New Features
-
+* Add new functions `cider-browse-spec` and `cider-browse-spec-all` which starts a spec browser.
 * [#2015](https://github.com/clojure-emacs/cider/pull/2015): Show symbols as special forms *and* macros in `cider-doc`
 * [#2012](https://github.com/clojure-emacs/cider/pull/2012): Support special forms in `cider-apropos` and `cider-grimoire-lookup`.
 * [#2007](https://github.com/clojure-emacs/cider/pull/2007): Fontify code blocks from `cider-grimoire` if possible.

cider-browse-spec.el

@@ -0,0 +1,342 @@
+;;; cider-browse-spec.el --- CIDER spec browser
+
+;; Copyright © 2014-2017 Juan Monetta, Bozhidar Batsov and CIDER contributors
+
+;; Author: Juan Monetta <[email protected]>
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;; This file is not part of GNU Emacs.
+
+;;; Commentary:
+
+;; M-x cider-browse-spec
+;;
+;; Display a spec description you can browse.
+;; Pressing <enter> over a sub spec will take you to the description of that sub spec.
+;; Pressing ^ will take you up in the navigation stack.
+
+;; M-x cider-browse-spec-all
+;;
+;; Explore clojure.spec registry by browsing a list of all specs.
+;; Pressing <enter> over a spec display the spec description you can browse.
+
+;;; Code:
+
+(require 'cider-interaction)
+(require 'cider-client)
+(require 'subr-x)
+(require 'cider-compat)
+(require 'cider-util)
+(require 'nrepl-dict)
+(require 'seq)
+
+;; The buffer names used by the spec browser
+(defconst cider-browse-spec-buffer "*cider-spec-browser*")
+(defconst cider-browse-spec-example-buffer "*cider-spec-example*")
+
+(push cider-browse-spec-buffer cider-ancillary-buffers)
+(push cider-browse-spec-example-buffer cider-ancillary-buffers)
+
+(defvar cider-browse-spec-navigation '()
+  "Keeps the cider spec browser navigation stack.
+A list of strings which are specs or specs searches.
+First of the list is the top of the stack.
+Specs searches are encoded as \"*prefix\"
+For example: (\":ring.request/header-name\" \":ring.request/headers\" \":ring/request\" \"*ring\")")
+
+;; Mode Definition
+
+(defvar cider-browse-spec-mode-map
+  (let ((map (make-sparse-keymap)))
+    (set-keymap-parent map cider-popup-buffer-mode-map)
+    (define-key map (kbd "RET") #'cider-browse-spec--browse-at-point)
+    (define-key map "^" #'cider-browse-spec--navigate-back)
+    (define-key map "n" #'cider-browse-spec--next-spec)
+    (define-key map "p" #'cider-browse-spec--prev-spec)
+    (define-key map "e" #'cider-browse-spec--print-curr-spec-example)
+    map))
+
+(defvar cider-browse-spec-mouse-map
+  (let ((map (make-sparse-keymap)))
+    (define-key map [mouse-1] #'cider-browse-spec-handle-mouse)
+    map))
+
+(define-derived-mode cider-browse-spec-mode special-mode "browse-spec"
+  "Major mode for browsing Clojure specs.
+
+\\{cider-browse-spec-mode-map}"
+  (setq buffer-read-only t)
+  (setq-local electric-indent-chars nil)
+  (when cider-special-mode-truncate-lines
+    (setq-local truncate-lines t)))
+
+;; Non interactive functions
+
+(defun cider-browse-spec--clear-nav-history ()
+    "Clears `cider-browse-spec-navigation'."
+  (setq cider-browse-spec-navigation '()))
+
+(defun cider-browse-spec--propertize-keyword (kw)
+  "Add properties to KW text needed by the spec browser."
+  (propertize kw
+              'font-lock-face 'clojure-keyword-face
+              'spec-name kw
+              'mouse-face 'highlight
+              'keymap cider-browse-spec-mouse-map))
+
+(defun cider-browse-spec--propertize-fn (fname)
+  "Add properties to FNAME symbol text needed by the spec browser."
+  (propertize fname
+              'font-lock-face 'font-lock-function-name-face
+              'spec-name fname
+              'mouse-face 'highlight
+              'keymap cider-browse-spec-mouse-map))
+
+
+(defun cider-browse-spec--draw-list-buffer (buffer title specs)
+  "Reset contents of BUFFER.
+Display TITLE at the top and SPECS are indented underneath."
+  (with-current-buffer buffer
+    (cider-browse-spec-mode)
+    (let ((inhibit-read-only t))
+      (erase-buffer)
+      (goto-char (point-max))
+      (insert (cider-propertize title 'emph) "\n\n")
+      (dolist (spec-name specs)
+        (insert (format "\t%s\n"
+                        (if (char-equal (elt spec-name 0) ?:)
+                            (cider-browse-spec--propertize-keyword spec-name)
+                          (cider-browse-spec--propertize-fn spec-name)))))
+      (goto-char (point-min)))))
+
+(defun qualified-keyword-p (str)
+  "Return non nil if STR is a namespaced keyword."
+  (string-match-p "^:.+/.+$" str))
+
+(defun spec-fn-p (value fn-name)
+  "Return non nil if VALUE is clojure.spec.[alpha]/FN-NAME."
+  (string-match-p (concat "^\\(clojure.spec\\|clojure.spec.alpha\\)/" fn-name "$") value))
+
+(defun cider-browse-spec--pprint (form)
+  "Given a spec FORM builds a multi line string with a pretty render of that FORM."
+  (cond ((stringp form)
+         (if (qualified-keyword-p form)
+             (cider-browse-spec--propertize-keyword form)
+           ;; to make it easier to read replace all clojure.spec ns with s/
+           ;; and remove all clojure.core ns
+           (thread-last form
+             (replace-regexp-in-string "^\\(clojure.spec\\|clojure.spec.alpha\\)/" "s/")
+             (replace-regexp-in-string "^\\(clojure.core\\)/" ""))))
+
+        ((and (listp form) (stringp (first form)))
+         (let ((form-tag (first form)))
+           (cond
+            ;; prettier fns #()
+            ((string-equal form-tag "clojure.core/fn")
+             (if (equal (second form) '("%"))
+                 (format "#%s" (reduce #'concat (mapcar #'cider-browse-spec--pprint (rest (rest form))))))
+             (format "(fn [%%] %s)" (reduce #'concat (mapcar #'cider-browse-spec--pprint (rest (rest form))))))
+            ;; prettier (s/and )
+            ((spec-fn-p form-tag "and")
+             (format "(s/and\n%s)" (string-join (thread-last (rest form)
+                                                  (mapcar #'cider-browse-spec--pprint)
+                                                  (mapcar (lambda (x) (format "%s" x))))
+                                                "\n")))
+            ;; prettier (s/or )
+            ((spec-fn-p form-tag "or")
+             (let ((name-spec-pair (seq-partition (rest form) 2)))
+               (format "(s/or\n%s)" (string-join
+                                     (thread-last name-spec-pair
+                                       (mapcar (lambda (s) (format "%s %s" (first s) (cider-browse-spec--pprint (second s))))))
+                                     "\n"))))
+            ;; prettier (s/merge )
+            ((spec-fn-p form-tag "merge")
+             (format "(s/merge\n%s)" (string-join (thread-last (rest form)
+                                                    (mapcar #'cider-browse-spec--pprint)
+                                                    (mapcar (lambda (x) (format "%s" x))))
+                                                  "\n")))
+            ;; prettier (s/keys )
+            ((spec-fn-p form-tag "keys")
+             (let ((keys-args (seq-partition (rest form) 2)))
+               (format "(s/keys%s)" (thread-last
+                                        keys-args
+                                      (mapcar (lambda (s)
+                                                (let ((key-type (first s))
+                                                      (specs-vec (second s)))
+                                                  (concat "\n" key-type
+                                                          " ["
+                                                          (string-join (thread-last specs-vec
+                                                                         (mapcar #'cider-browse-spec--pprint)
+                                                                         (mapcar (lambda (x) (format "%s" x))))
+                                                                       "\n")
+                                                          "]"))))
+                                      (reduce #'concat)))))
+            ;; prettier (s/multi-spec)
+            ((spec-fn-p form-tag "multi-spec")
+             (let ((multi-method (second form))
+                   (retag (third form))
+                   (sub-specs (rest (rest (rest form)))))
+               (format "(s/multi-spec %s %s\n%s)"
+                       multi-method
+                       retag
+                       (string-join
+                        (thread-last sub-specs
+                          (mapcar (lambda (s)
+                                    (concat "\n\n" (first s) " " (cider-browse-spec--pprint (second s))))))
+                        "\n"))))
+            ;; prettier (s/cat )
+            ((spec-fn-p form-tag "cat")
+             (let ((name-spec-pairs (seq-partition (rest form) 2)))
+               (format "(s/cat %s)"
+                       (thread-last name-spec-pairs
+                         (mapcar (lambda (s)
+                                   (concat "\n" (first s) " " (cider-browse-spec--pprint (second s)))))
+                         (reduce #'concat)))))
+            ;; prettier (s/alt )
+            ((spec-fn-p form-tag "alt")
+             (let ((name-spec-pairs (seq-partition (rest form) 2)))
+               (format "(s/alt %s)"
+                       (thread-last name-spec-pairs
+                         (mapcar (lambda (s)
+                                   (concat "\n" (first s) " " (cider-browse-spec--pprint (second s)))))
+                         (reduce #'concat)))))
+            ;; prettier (s/fspec )
+            ((spec-fn-p form-tag "fspec")
+             (thread-last (seq-partition (rest form) 2)
+               (mapcar (lambda (s)
+                         (concat "\n" (first s) " " (cider-browse-spec--pprint (second s)))))
+               (reduce #'concat)
+               (format "(s/fspec \n %s)")))
+            ;; every other with no special management
+            ('t (format "(%s %s)"
+                        (cider-browse-spec--pprint form-tag)
+                        (string-join (mapcar #'cider-browse-spec--pprint (rest form)) " "))))))
+        ('t (format "%s" form))))
+
+(defun cider-browse-spec--draw-spec-buffer (buffer spec spec-form)
+  "Reset contents of BUFFER and draws everything needed to browse the SPEC-FORM.
+Display SPEC as a title and uses `cider-browse-spec--pprint' to display
+a more user friendly representation of SPEC-FORM."
+  (with-current-buffer buffer
+    (let ((inhibit-read-only t))
+      (erase-buffer)
+      (goto-char (point-max))
+      (insert (format "Spec for : %s\n\n" spec))
+      (insert-text-button "[Back]"
+                          'action (lambda (b) (call-interactively 'cider-browse-spec--navigate-back))
+                          'follow-link t)
+      (insert "\n\n")
+      (insert (cider-browse-spec--pprint spec-form))
+      (clojure-mode)
+      (indent-region (point-min) (point))
+      (cider-browse-spec-mode)
+      (goto-char (point-min)))))
+
+(defun cider-browse-spec--browse (spec)
+  "Browse SPEC pushing it into `cider-browse-spec-navigation'."
+  (with-current-buffer (cider-popup-buffer cider-browse-spec-buffer t)
+    (push spec cider-browse-spec-navigation)
+    (cider-browse-spec--draw-spec-buffer (current-buffer)
+                             spec
+                             (cider-sync-request:spec-form spec))))
+
+(defun cider-browse-spec--is-nav-filterp (str-filter)
+  "Return non nil if STR-FILTER is a filter term."
+  (char-equal (elt str-filter 0) ?*))
+
+
+;; Interactive Functions
+
+(defun cider-browse-spec--next-spec ()
+  "Move to the next spec in the buffer."
+  (interactive)
+  (goto-char (next-single-property-change (point) 'spec-name))
+  (when (not (get-text-property (point) 'spec-name))
+      (goto-char (next-single-property-change (point) 'spec-name))))
+
+(defun cider-browse-spec--prev-spec ()
+  "Move to the previous spec in the buffer."
+  (interactive)
+  (goto-char (previous-single-property-change (point) 'spec-name))
+  (when (not (get-text-property (point) 'spec-name))
+    (goto-char (previous-single-property-change (point) 'spec-name))))
+
+(defun cider-browse-spec--print-curr-spec-example ()
+  "Generate and print a spec example of the current spec in `cider-browse-spec-navigation'."
+  (interactive)
+  (when (not (null cider-browse-spec-navigation))
+    (let* ((spec (first cider-browse-spec-navigation))
+           (example (cider-sync-request:spec-example spec)))
+      (with-current-buffer (cider-popup-buffer cider-browse-spec-example-buffer t)
+        (cider-browse-spec-mode)
+        (let ((inhibit-read-only t))
+          (erase-buffer)
+          (goto-char (point-max))
+          (insert (cider-propertize (concat "Example of: " spec) 'emph) "\n\n")
+          (insert example)
+          (goto-char (point-min)))))))
+
+;;;###autoload
+(defun cider-browse-spec (spec)
+  "Start a new navigation and browse to SPEC definition."
+  (interactive (list (completing-read "Browse spec: "
+                                      (cider-sync-request:spec-list "")
+                                      nil nil
+                                      (cider-symbol-at-point))))
+  (cider-browse-spec--clear-nav-history)
+  (cider-browse-spec--browse spec))
+
+
+;;;###autoload
+(defun cider-browse-spec-all (filter-regex)
+  "List all loaded specs in BUFFER filtered by FILTER-REGEX.
+If FILTER-REGEX is empty, list all specs in the registry."
+  (interactive (list (read-string "Filter prefix: ")))
+  (with-current-buffer (cider-popup-buffer cider-browse-spec-buffer t)
+    (let ((specs (cider-sync-request:spec-list filter-regex)))
+      (cider-browse-spec--clear-nav-history)
+      (push (concat "*" filter-regex) cider-browse-spec-navigation)
+      (cider-browse-spec--draw-list-buffer (current-buffer)
+                                           (if (string-empty-p filter-regex)
+                                   "All specs in registry"
+                                 (format "All specs with `%s' prefix in registry" filter-regex))
+                               specs))))
+
+(defun cider-browse-spec--browse-at-point ()
+  "Go to the definition of the spec at point inside `cider-browse-spec-buffer'."
+  (interactive)
+  (when-let ((spec (get-text-property (point) 'spec-name)))
+    (cider-browse-spec--browse spec)))
+
+(defun cider-browse-spec--navigate-back ()
+  "Move the browser back in `cider-browse-spec-navigation'."
+  (interactive)
+  (if (> (length cider-browse-spec-navigation) 1)
+      (progn
+       (pop cider-browse-spec-navigation) ;; discard current
+       (if (cider-browse-spec--is-nav-filterp (first cider-browse-spec-navigation))
+           (cider-browse-spec-all (substring (pop cider-browse-spec-navigation) 1))
+         (cider-browse-spec--browse (pop cider-browse-spec-navigation))))
+    (when (not (cider-browse-spec--is-nav-filterp (first cider-browse-spec-navigation)))
+      (cider-browse-spec-all ""))))
+
+(defun cider-browse-spec-handle-mouse (event)
+  "Handle mouse click EVENT."
+  (interactive "e")
+  (cider-browse-spec--browse-at-point))
+
+(provide 'cider-browse-spec)
+
+;;; cider-browse-spec.el ends here

cider-client.el

@@ -952,6 +952,27 @@ CONTEXT represents a completion context for compliment."
         nil
       eldoc)))
 
+(defun cider-sync-request:spec-list (filter-regex)
+  "Get a list of the available specs in the registry."
+  (thread-first `("op" "spec-list"
+                  "filter-regex" ,filter-regex)
+    (cider-nrepl-send-sync-request)
+    (nrepl-dict-get "spec-list")))
+
+(defun cider-sync-request:spec-form (spec)
+  "Get spec form from registry"
+  (thread-first `("op" "spec-form"
+                  "spec-name" ,spec)
+    (cider-nrepl-send-sync-request)
+    (nrepl-dict-get "spec-form")))
+
+(defun cider-sync-request:spec-example (spec)
+  "Get a spec example"
+  (thread-first `("op" "spec-example"
+                  "spec-name" ,spec)
+    (cider-nrepl-send-sync-request)
+    (nrepl-dict-get "spec-example")))
+
 (defun cider-sync-request:ns-list ()
   "Get a list of the available namespaces."
   (thread-first `("op" "ns-list"