[Fix #1859] In message log insert large objects on request only

CHANGELOG.md

@@ -14,6 +14,7 @@ within the scope of your current Emacs session.
 * [#1748](https://github.com/clojure-emacs/cider/issues/1748): Add new interactive command `cider-pprint-eval-last-sexp-to-repl`.
 * [#1789](https://github.com/clojure-emacs/cider/issues/1789): Make it easy to change the connection of the cider-scratch buffer from the mode's menu.
 * New interactive command `cider-toggle-buffer-connection`.
+* [#1861](https://github.com/clojure-emacs/cider/issues/1861): New interactive commands in message log buffer `nrepl-log-expand-button` and `nrepl-log-expand-all-buttons`.
 
 ### Changes
 
@@ -26,6 +27,8 @@ within the scope of your current Emacs session.
 * Add option to define exclusions for injected dependecies. Fixes [#1824](https://github.com/clojure-emacs/cider/issues/1824): Can no longer jack-in to an inherited clojure version.
 * [#1820](https://github.com/clojure-emacs/cider/issues/1820): Don't try to display eldoc in EDN buffers.
 * [#1823](https://github.com/clojure-emacs/cider/issues/1823): Fix column location metadata set by interactive evaluation.
+* [#1859](https://github.com/clojure-emacs/cider/issues/1859): Make nREPL message log much faster. `nrepl-dict-max-message-size` custom variable was removed.
+
 
 ## 0.13.0 (2016-07-25)
 

nrepl-client.el

@@ -1058,9 +1058,12 @@ operations.")
 
 (defvar nrepl-messages-mode-map
   (let ((map (make-sparse-keymap)))
-    (define-key map (kbd "n") #'next-line)
-    (define-key map (kbd "p") #'previous-line)
+    (define-key map (kbd "n")   #'next-line)
+    (define-key map (kbd "p")   #'previous-line)
     (define-key map (kbd "TAB") #'forward-button)
+    (define-key map (kbd "RET") #'nrepl-log-expand-button)
+    (define-key map (kbd "e")   #'nrepl-log-expand-button)
+    (define-key map (kbd "E")   #'nrepl-log-expand-all-buttons)
     (define-key map (kbd "<backtab>") #'backward-button)
     map))
 
@@ -1084,11 +1087,8 @@ operations.")
 
 (defun nrepl-log-message (msg type)
   "Log the nREPL MSG.
-
-TYPE is either request or response.
-
-The message is logged to a buffer described by
-`nrepl-message-buffer-name-template'."
+TYPE is either request or response.  The message is logged to a buffer
+described by `nrepl-message-buffer-name-template'."
   (when nrepl-log-messages
     (with-current-buffer (nrepl-messages-buffer (current-buffer))
       (setq buffer-read-only nil)
@@ -1097,8 +1097,9 @@ The message is logged to a buffer described by
         (re-search-forward "^(" nil t)
         (delete-region (point-min) (- (point) 1)))
       (goto-char (point-max))
-      (nrepl--pp (nrepl-decorate-msg msg type)
-                 (nrepl--message-color (lax-plist-get (cdr msg) "id")))
+      (nrepl-log-pp-object (nrepl-decorate-msg msg type)
+                           (nrepl-log--message-color (lax-plist-get (cdr msg) "id"))
+                           t)
       (when-let ((win (get-buffer-window)))
         (set-window-point win (point-max)))
       (setq buffer-read-only t))))
@@ -1119,75 +1120,121 @@ This in effect enables or disables the logging of nREPL messages."
   :type '(repeat color)
   :group 'nrepl)
 
-(defun nrepl--message-color (id)
+(defun nrepl-log-expand-button (&optional button)
+  "Expand the objects hidden in BUTTON's :nrepl-object property.
+BUTTON defaults the button at point."
+  (interactive)
+  (if-let ((button (or button (button-at (point)))))
+      (let* ((start (overlay-start button))
+             (end   (overlay-end   button))
+             (obj   (overlay-get button :nrepl-object))
+             (inhibit-read-only t))
+        (save-excursion
+          (goto-char start)
+          (delete-overlay button)
+          (delete-region start end)
+          (nrepl-log-pp-object obj)
+          (delete-char -1)))
+    (error "No button at point")))
+
+(defun nrepl-log-expand-all-buttons ()
+  "Expand all buttons in nREPL log buffer."
+  (interactive)
+  (if (not (eq major-mode 'nrepl-messages-mode))
+      (user-error "Not in a `nrepl-messages-mode'")
+    (save-excursion
+      (let* ((pos (point-min))
+             (button (next-button pos)))
+        (while button
+          (setq pos (overlay-start button))
+          (nrepl-log-expand-button button)
+          (setq button (next-button pos)))))))
+
+(defun nrepl-log--expand-button-mouse (event)
+  "Expand the text hidden under overlay button.
+EVENT gives the button position on window."
+  (interactive "e")
+  (pcase (elt event 1)
+    (`(,window ,_ ,_ ,_ ,_ ,point . ,_)
+     (with-selected-window window
+       (nrepl-log-expand-button (button-at point))))))
+
+(defun nrepl-log-insert-button (label object)
+  "Insert button with LABEL and :nrepl-object property as OBJECT."
+  (insert-button label
+                 :nrepl-object object
+                 'action #'nrepl-log-expand-button
+                 'face 'link
+                 'help-echo "RET: Expand object."
+                 ;; Workaround for bug#1568 (don't use local-map here; it
+                 ;; overwrites major mode map.)
+                 'keymap `(keymap (mouse-1 . nrepl-log--expand-button-mouse)))
+  (insert "\n"))
+
+(defun nrepl-log--message-color (id)
   "Return the color to use when pretty-printing the nREPL message with ID.
 If ID is nil, return nil."
   (when id
     (thread-first (string-to-number id)
       (mod (length nrepl-message-colors))
       (nth nrepl-message-colors))))
 
-(defcustom nrepl-dict-max-message-size 5
-  "Max number of lines a dict can have before being truncated.
-Set this to nil to prevent truncation."
-  :type 'integer)
-
-(defun nrepl--expand-button (button)
-  "Expand the text hidden under overlay BUTTON."
-  (delete-overlay button))
-
-(defun nrepl--expand-button-mouse (event)
-  "Expand the text hidden under overlay button.
-EVENT gives the button position on window."
-  (interactive "e")
-  (pcase (elt event 1)
-    (`(,window ,_ ,_ ,_ ,_ ,point . ,_)
-     (with-selected-window window
-       (nrepl--expand-button (button-at point))))))
-
-(define-button-type 'nrepl--collapsed-dict
-  'display "..."
-  'action #'nrepl--expand-button
-  'face 'link
-  'help-echo "RET: Expand dict.")
-
-(defun nrepl--pp (object &optional foreground)
-  "Pretty print nREPL OBJECT, delimited using FOREGROUND."
-  (if (not (and (listp object)
-                (memq (car object) '(<-- --> dict))))
-      (progn (when (stringp object)
-               (setq object (substring-no-properties object)))
-             (pp object (current-buffer))
-             (unless (listp object) (insert "\n")))
+(defun nrepl-log--pp-listlike (object &optional foreground button)
+  "Pretty print nREPL list like OBJECT.
+FOREGROUND and BUTTON are as in `nrepl-log-pp-object'."
+  (cl-flet ((color (str)
+                   (propertize str 'face
+                               (append '(:weight ultra-bold)
+                                       (when foreground `(:foreground ,foreground))))))
     (let ((head (format "(%s" (car object))))
-      (cl-flet ((color (str)
-                       (propertize str 'face (append '(:weight ultra-bold)
-                                                     (when foreground `(:foreground ,foreground))))))
-        (insert (color head))
-        (let ((indent (+ 2 (- (current-column) (length head))))
-              (l (point)))
-          (if (null (cdr object))
-              (insert ")\n")
-            (insert " \n")
-            (cl-loop for l on (cdr object) by #'cddr
-                     do (let ((str (format "%s%s  " (make-string indent ?\s)
-                                           (propertize (car l) 'face
-                                                       ;; Only highlight top-level keys.
-                                                       (unless (eq (car object) 'dict)
-                                                         'font-lock-keyword-face)))))
-                          (insert str)
-                          (nrepl--pp (cadr l))))
-            (when (eq (car object) 'dict)
-              (delete-char -1)
-              (let ((truncate-lines t))
-                (when (and nrepl-dict-max-message-size
-                           (> (count-screen-lines l (point) t)
-                              nrepl-dict-max-message-size))
-                  (make-button (1+ l) (point)
-                               :type 'nrepl--collapsed-dict
-                               ;; Workaround for bug#1568.
-                               'local-map '(keymap (mouse-1 . nrepl--expand-button-mouse))))))
-            (insert (color ")\n"))))))))
+      (insert (color head))
+      (let ((indent (+ 2 (- (current-column) (length head))))
+            (l (point)))
+        (if (null (cdr object))
+            (insert ")\n")
+          (insert " \n")
+          (cl-loop for l on (cdr object) by #'cddr
+                   do (let ((str (format "%s%s  " (make-string indent ?\s)
+                                         (propertize (car l) 'face
+                                                     ;; Only highlight top-level keys.
+                                                     (unless (eq (car object) 'dict)
+                                                       'font-lock-keyword-face)))))
+                        (insert str)
+                        (nrepl-log-pp-object (cadr l) nil button)))
+          (when (eq (car object) 'dict)
+            (delete-char -1))
+          (insert (color ")\n")))))))
+
+(defun nrepl-log-pp-object (object &optional foreground button)
+  "Pretty print nREPL OBJECT, delimited using FOREGROUND.
+If BUTTON is non-nil, try making a button from OBJECT instead of inserting
+it into the buffer."
+  (let ((min-dict-fold-size   1)
+        (min-list-fold-size   10)
+        (min-string-fold-size 60))
+    (if-let ((head (car-safe object)))
+        ;; list-like objects
+        (cond
+         ;; top level dicts (always expanded)
+         ((memq head '(<-- -->))
+          (nrepl-log--pp-listlike object foreground button))
+         ;; inner dicts
+         ((eq head 'dict)
+          (if (and button (> (length object) min-dict-fold-size))
+              (nrepl-log-insert-button "(dict ...)" object)
+            (nrepl-log--pp-listlike object foreground button)))
+         ;; lists
+         (t
+          (if (and button (> (length object) min-list-fold-size))
+              (nrepl-log-insert-button (format "(%s ...)" (prin1-to-string head)) object)
+            (pp object (current-buffer)))))
+      ;; non-list objects
+      (if (stringp object)
+          (if (and button (> (length object) min-string-fold-size))
+              (nrepl-log-insert-button (format "\"%s...\"" (substring object 0 min-string-fold-size)) object)
+            (insert (prin1-to-string object) "\n"))
+        (pp object (current-buffer))
+        (insert "\n")))))
 
 (defun nrepl-messages-buffer-name (conn)
   "Return the name for the message buffer matching CONN."