Add support for displaying various images (#2248)

4 files changed, 174 insertions, 30 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index e8ea3bbb..414ae81a 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -4,6 +4,7 @@
 
 ### New features
 
+* [#2248](https://github.com/clojure-emacs/cider/pull/2248): `cider-repl` can now display recognized images in the REPL buffer.
 * [#2172](https://github.com/clojure-emacs/cider/pull/2172): Render diffs for expected / actual test results.
 * [#2167](https://github.com/clojure-emacs/cider/pull/2167): Add new defcustom `cider-jdk-src-paths`. Configure it to connect stack trace links to Java source code.
 * [#2161](https://github.com/clojure-emacs/cider/issues/2161): Add new interactive command `cider-eval-defun-to-point` which is bound to `C-c C-v (C-)z`. It evaluates the current top-level form up to the point.
diff --git a/cider-client.el b/cider-client.el
index 3c9b5fc9..df5b1431 100644
--- a/cider-client.el
+++ b/cider-client.el
@@ -780,6 +780,10 @@ result, and is included in the request if non-nil."
            "pprint-fn" ,(or pprint-fn (cider--pprint-fn)))
          (and right-margin `("print-right-margin" ,right-margin))))
 
+(defun cider--nrepl-content-type-plist ()
+  "Plist to be appended to an eval request to make it use content-types."
+  '("content-type" "true"))
+
 (defun cider-tooling-eval (input callback &optional ns)
   "Send the request INPUT and register the CALLBACK as the response handler.
 NS specifies the namespace in which to evaluate the request.
diff --git a/cider-repl.el b/cider-repl.el
index 68beee47..68b7d10e 100644
--- a/cider-repl.el
+++ b/cider-repl.el
@@ -9,6 +9,7 @@
 ;;         Artur Malabarba <bruce.connor.am@gmail.com>
 ;;         Hugo Duncan <hugo@hugoduncan.org>
 ;;         Steve Purcell <steve@sanityinc.com>
+;;         Reid McKenzie <me@arrdem.com>
 
 ;; 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
@@ -112,7 +113,7 @@ If this is set to nil, no re-centering takes place."
   :package-version '(cider . "0.11.0"))
 
 (defcustom cider-repl-use-pretty-printing nil
-  "Control whether the results in REPL are pretty-printed or not.
+  "Control whether results in the REPL are pretty-printed or not.
 The `cider-toggle-pretty-printing' command can be used to interactively
 change the setting's value."
   :type 'boolean
@@ -127,6 +128,13 @@ defaults to the variable `fill-column'."
   :group 'cider-repl
   :package-version '(cider . "0.15.0"))
 
+(defcustom cider-repl-use-content-types t
+  "Control whether REPL results are presented using content-type information or not.
+The `cider-toggle-content-types' command can be used to interactively
+change the setting's value."
+  :type 'boolean
+  :group 'cider-repl)
+
 (defcustom cider-repl-use-clojure-font-lock t
   "Non-nil means to use Clojure mode font-locking for input and result.
 Nil means that `cider-repl-input-face' and `cider-repl-result-face'
@@ -799,24 +807,133 @@ the symbol."
                t)))
           (t t))))
 
+(defun cider-repl--display-image (buffer image &optional show-prefix bol string)
+  "Insert IMAGE into BUFFER at the current point.
+
+For compatibility with the rest of CIDER's REPL machinery, supports
+SHOW-PREFIX and BOL."
+  (with-current-buffer buffer
+    (save-excursion
+      (cider-save-marker cider-repl-output-start
+        (cider-save-marker cider-repl-output-end
+          (goto-char cider-repl-input-start-mark)
+          (when (and bol (not (bolp)))
+            (insert-before-markers "\n"))
+          (when show-prefix
+            (insert-before-markers
+             (propertize cider-repl-result-prefix 'font-lock-face 'font-lock-comment-face)))
+          (insert-image image string)
+          (set-marker cider-repl-input-start-mark (point) buffer)
+          (set-marker cider-repl-prompt-start-mark (point) buffer))))
+    (cider-repl--show-maximum-output))
+  t)
+
+(defcustom cider-repl-image-margin 10
+  "Specifies the margin to be applied to images displayed in the REPL.
+
+Either a single number of pixels - interpreted as a symmetric margin, or
+pair of numbers `(x . y)' encoding an arbitrary margin."
+  :type '(choice integer (vector integer integer))
+  :group 'cider-repl
+  :package-version '(cider . "0.17.0"))
+
+(defun cider-repl--image (data type datap)
+  "A helper for creating images with CIDER's image options.
+
+FILE-OR-DATA is either the path to an image or its base64 coded data.  TYPE
+is a symbol indicating the image type.  DATAP indicates whether the image is
+the raw image data or a filename.
+
+Returns an image instance with a margin per `cider-repl-image-margin'."
+  (create-image data type datap
+                :margin cider-repl-image-margin))
+
+(defun cider-repl-handle-jpeg (_type buffer image &optional show-prefix bol)
+  "A handler for inserting a jpeg IMAGE into a repl BUFFER.
+Part of the default `cider-repl-content-type-handler-alist'."
+  (cider-repl--display-image buffer
+                             (cider-repl--image image 'jpeg t)
+                             show-prefix bol image))
+
+(defun cider-repl-handle-png (_type buffer image &optional show-prefix bol)
+  "A handler for inserting a png IMAGE into a repl BUFFER.
+Part of the default `cider-repl-content-type-handler-alist'."
+  (cider-repl--display-image buffer
+                             (cider-repl--image image 'png t)
+                             show-prefix bol image))
+
+(defun cider-repl-handle-external-body (type buffer _ &optional show-prefix bol)
+  "Handler for slurping external content into BUFFER.
+Handles an external-body TYPE by issuing a slurp request to fetch the content."
+  (if-let* ((args        (second type))
+            (access-type (nrepl-dict-get args "access-type")))
+      (nrepl-send-request
+       (list "op" "slurp" "url" (nrepl-dict-get args "URL"))
+       (cider-repl-handler buffer)
+       (cider-current-connection)))
+  nil)
+
+(defcustom cider-repl-content-type-handler-alist
+  `(("message/external-body" . ,#'cider-repl-handle-external-body)
+    ("image/jpeg" . ,#'cider-repl-handle-jpeg)
+    ("image/png" . ,#'cider-repl-handle-png))
+  "Association list from content-types to handlers.
+
+Handlers must be functions of two required and two optional arguments - the
+REPL buffer to insert into, the value of the given content type as a raw
+string, the REPL's show prefix as any and an `end-of-line' flag.
+
+The return value of the handler should be a flag, indicating whether or not
+the REPL is ready for a prompt to be displayed. Most handlers should return
+`t', as the content-type response is (currently) an alternative to the
+value response. However for handlers which themselves issue subsequent
+nREPL ops, it may be convenient to prevent inserting a prompt."
+  :group 'cider-repl
+  :package-version '(cider . "0.17.0"))
+
 (defun cider-repl-handler (buffer)
   "Make an nREPL evaluation handler for the REPL BUFFER."
-  (nrepl-make-response-handler buffer
-                               (let (after-first-result-chunk)
-                                 (lambda (buffer value)
-                                   (cider-repl-emit-result buffer value (not after-first-result-chunk) t)
-                                   (setq after-first-result-chunk t)))
-                               (lambda (buffer out)
-                                 (cider-repl-emit-stdout buffer out))
-                               (lambda (buffer err)
-                                 (cider-repl-emit-stderr buffer err))
-                               (lambda (buffer)
-                                 (cider-repl-emit-prompt buffer))
-                               nrepl-err-handler
-                               (let (after-first-result-chunk)
-                                 (lambda (buffer pprint-out)
-                                   (cider-repl-emit-result buffer pprint-out (not after-first-result-chunk))
-                                   (setq after-first-result-chunk t)))))
+  (let (after-first-result-chunk
+        (show-prompt t))
+    (nrepl-make-response-handler
+     buffer
+     (lambda (buffer value)
+       (cider-repl-emit-result buffer value (not after-first-result-chunk) t)
+       (setq after-first-result-chunk t))
+     (lambda (buffer out)
+       (cider-repl-emit-stdout buffer out))
+     (lambda (buffer err)
+       (cider-repl-emit-stderr buffer err))
+     (lambda (buffer)
+       (when show-prompt
+         (cider-repl-emit-prompt buffer)
+         (let ((win (get-buffer-window (current-buffer) t)))
+           (when win
+             (with-selected-window win
+               (set-window-point win cider-repl-input-start-mark))
+             (cider-repl--show-maximum-output)))))
+     nrepl-err-handler
+     (lambda (buffer pprint-out)
+       (cider-repl-emit-result buffer pprint-out (not after-first-result-chunk))
+       (setq after-first-result-chunk t))
+     (lambda (buffer value content-type)
+       (if-let* ((content-attrs (second content-type))
+                 (content-type* (first content-type))
+                 (handler (cdr (assoc content-type*
+                                      cider-repl-content-type-handler-alist))))
+           (setq after-first-result-chunk t
+                 show-prompt (funcall handler content-type buffer value
+                                      (not after-first-result-chunk) t))
+         (progn (cider-repl-emit-result buffer value (not after-first-result-chunk) t)
+                (setq after-first-result-chunk t)))))))
+
+(defun cider--repl-request-plist (right-margin &optional pprint-fn)
+  "Plist to be appended to generic eval requests, as for the REPL.
+PPRINT-FN and RIGHT-MARGIN are as in `cider--nrepl-pprint-request-plist'."
+  (nconc (when cider-repl-use-pretty-printing
+           (cider--nrepl-pprint-request-plist right-margin pprint-fn))
+         (when cider-repl-use-content-types
+           (cider--nrepl-content-type-plist))))
 
 (defun cider-repl--send-input (&optional newline)
   "Go to the end of the input and send the current input.
@@ -858,9 +975,7 @@ If NEWLINE is true then add a newline at the end of the input."
          (cider-current-ns)
          (line-number-at-pos input-start)
          (cider-column-number-at-pos input-start)
-         (unless (or (not cider-repl-use-pretty-printing)
-                     (string-match-p "\\`[ \t\r\n]*\\'" input))
-           (cider--nrepl-pprint-request-plist (cider--pretty-print-width))))))))
+         (cider--repl-request-plist (cider--pretty-print-width)))))))
 
 (defun cider-repl-return (&optional end-of-input)
   "Evaluate the current input string, or insert a newline.
@@ -936,6 +1051,13 @@ text property `cider-old-input'."
       fill-column
       80))
 
+(defun cider-repl-toggle-content-types ()
+  "Toggle content-type rendering in the REPL."
+  (interactive)
+  (setq cider-repl-use-content-types (not cider-repl-use-content-types))
+  (message "Content-type support in REPL %s."
+           (if cider-repl-use-content-types "enabled" "disabled")))
+
 (defun cider-repl-switch-to-other ()
   "Switch between the Clojure and ClojureScript REPLs for the current project."
   (interactive)
diff --git a/nrepl-client.el b/nrepl-client.el
index 948ad96e..38e0cb53 100644
--- a/nrepl-client.el
+++ b/nrepl-client.el
@@ -9,6 +9,7 @@
 ;;         Artur Malabarba <bruce.connor.am@gmail.com>
 ;;         Hugo Duncan <hugo@hugoduncan.org>
 ;;         Steve Purcell <steve@sanityinc.com>
+;;         Reid McKenzie <me@arrdem.com>
 ;;
 ;; 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
@@ -764,7 +765,8 @@ to the REPL."
 (defun nrepl-make-response-handler (buffer value-handler stdout-handler
                                            stderr-handler done-handler
                                            &optional eval-error-handler
-                                           pprint-out-handler)
+                                           pprint-out-handler
+                                           content-type-handler)
   "Make a response handler for connection BUFFER.
 A handler is a function that takes one argument - response received from
 the server process.  The response is an alist that contains at least 'id'
@@ -773,20 +775,35 @@ and 'session' keys.  Other standard response keys are 'value', 'out', 'err',
 
 The presence of a particular key determines the type of the response.  For
 example, if 'value' key is present, the response is of type 'value', if
-'out' key is present the response is 'stdout' etc.  Depending on the type,
-the handler dispatches the appropriate value to one of the supplied
-handlers: VALUE-HANDLER, STDOUT-HANDLER, STDERR-HANDLER, DONE-HANDLER,
-EVAL-ERROR-HANDLER, and PPRINT-OUT-HANDLER.  If the optional
-EVAL-ERROR-HANDLER is nil, the default `nrepl-err-handler' is used.  If any
-of the other supplied handlers are nil nothing happens for the
-corresponding type of response."
+'out' key is present the response is 'stdout' etc.
+
+Depending on the type, the handler dispatches the appropriate value to one
+of the supplied handlers: VALUE-HANDLER, STDOUT-HANDLER, STDERR-HANDLER,
+DONE-HANDLER, EVAL-ERROR-HANDLER, PPRINT-OUT-HANDLER and
+CONTENT-TYPE-HANDLER.
+
+Handlers are functions of the buffer and the value they handle, except for
+the optional CONTENT-TYPE-HANDLER which should be a function of the buffer,
+content, the content-type to be handled as a list `(type attrs)'.
+
+If the optional EVAL-ERROR-HANDLER is nil, the default `nrepl-err-handler'
+is used.  If any of the other supplied handlers are nil nothing happens for
+the corresponding type of response."
   (lambda (response)
-    (nrepl-dbind-response response (value ns out err status id pprint-out)
+    (nrepl-dbind-response response (content-type content-transfer-encoding body
+                                                 value ns out err status id
+                                                 pprint-out)
       (when (buffer-live-p buffer)
         (with-current-buffer buffer
           (when (and ns (not (derived-mode-p 'clojure-mode)))
             (cider-set-buffer-ns ns))))
-      (cond (value
+      (cond ((and content-type content-type-handler)
+             (funcall content-type-handler buffer
+                      (if (string= content-transfer-encoding "base64")
+                          (base64-decode-string body)
+                        body)
+                      content-type))
+            (value
              (when value-handler
                (funcall value-handler buffer value)))
             (out