emacs-jupyter/jupyter-mime.el

;;; jupyter-mime.el --- Insert mime types -*- lexical-binding: t -*-

;; Copyright (C) 2018 Nathaniel Nicandro

;; Author: Nathaniel Nicandro <nathanielnicandro@gmail.com>
;; Created: 09 Nov 2018
;; Version: 0.0.1

;; 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 2, 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Routines for working with MIME types.
;; Adds the following methods which may be extended:
;;
;; - jupyter-markdown-follow-link
;; - jupyter-insert

;;; Code:

(require 'jupyter-base)
(require 'shr)
(require 'ansi-color)

(declare-function org-format-latex "org" (prefix &optional beg end dir overlays msg forbuffer processing-type))
(declare-function markdown-link-at-pos "ext:markdown-mode" (pos))
(declare-function markdown-follow-link-at-point "ext:markdown-mode")

(defvar-local jupyter-display-ids nil
  "A hash table of display IDs.
Display IDs are implemented by setting the text property,
`jupyter-display', to the display ID requested by a
`:display-data' message. When a display is updated from an
`:update-display-data' message, the display ID from the initial
`:display-data' message is retrieved from this table and used to
find the display in the REPL buffer. See
`jupyter-update-display'.")

;;; Macros

;; Taken from `eshell-handle-control-codes'
(defun jupyter-handle-control-codes (beg end)
  "Handle any control sequences between BEG and END."
  (save-excursion
    (goto-char beg)
    (while (< (point) end)
      (let ((char (char-after)))
        (cond
         ((eq char ?\r)
          (if (< (1+ (point)) end)
              (if (memq (char-after (1+ (point)))
                        '(?\n ?\r))
                  (delete-char 1)
                (let ((end (1+ (point))))
                  (beginning-of-line)
                  (delete-region (point) end)))
            (add-text-properties (point) (1+ (point))
                                 '(invisible t))
            (forward-char)))
         ((eq char ?\a)
          (delete-char 1)
          (beep))
         ((eq char ?\C-h)
          (delete-region (1- (point)) (1+ (point))))
         (t
          (forward-char)))))))

(defmacro jupyter-with-control-code-handling (&rest body)
  "Handle control codes in any produced output generated by evaluating BODY.
After BODY is evaluated, call `jupyter-handle-control-codes'
on the region inserted by BODY."
  `(jupyter-with-insertion-bounds
       beg end (progn ,@body)
     (jupyter-handle-control-codes beg end)))

;;; Fontificiation routines

(defvar jupyter-fontify-buffers nil
  "An alist of (MODE . BUFFER) pairs used for fontification.
See `jupyter-fontify-according-to-mode'.")

(defun jupyter-get-fontify-buffer (mode)
  "Return the buffer used to fontify text for MODE.
Retrieve the buffer for MODE from `jupyter-repl-fontify-buffers'.
If no buffer for MODE exists, create a new one."
  (let ((buf (alist-get mode jupyter-fontify-buffers)))
    (unless buf
      (setq buf (get-buffer-create
                 (format " *jupyter-repl-fontify[%s]*" mode)))
      (with-current-buffer buf
        (funcall mode))
      (setf (alist-get mode jupyter-fontify-buffers) buf))
    buf))

(defun jupyter-fixup-font-lock-properties (beg end &optional object)
  "Fixup the text properties in the `current-buffer' between BEG END.
If OBJECT is non-nil, fixup the text properties of OBJECT. Fixing
the text properties involves substituting any `face' property
with `font-lock-face'."
  (let ((next beg) val)
    (while (/= beg end)
      (setq val (get-text-property beg 'face object)
            next (next-single-property-change beg 'face object end))
      (remove-text-properties beg next '(face) object)
      (put-text-property beg next 'font-lock-face (or val 'default) object)
      (setq beg next))))

(defun jupyter-add-font-lock-properties (start end &optional object)
  "Add font lock text properties between START and END in the `current-buffer'.
START, END, and OBJECT have the same meaning as in
`add-text-properties'. The properties added are the ones that
mark the text between START and END as fontified according to
font lock. Any text between START and END that does not have a
`font-lock-face' property will have the `default' face filled in
for the property."
  (jupyter-fixup-font-lock-properties start end object)
  (add-text-properties start end '(fontified t font-lock-fontified t) object))

(defun jupyter-fontify-according-to-mode (mode str)
  "Fontify a string according to MODE.
Return the fontified string. In addition to fontifying STR, if
MODE has a non-default `fill-forward-paragraph-function', STR
will be filled using `fill-region'."
  (with-current-buffer (jupyter-get-fontify-buffer mode)
    (with-silent-modifications
      (erase-buffer)
      (insert str)
      (font-lock-ensure)
      (jupyter-add-font-lock-properties (point-min) (point-max))
      (when (not (memq fill-forward-paragraph-function
                       '(forward-paragraph)))
        (fill-region (point-min) (point-max) t 'nosqueeze))
      (buffer-string))))

;;; `jupyter-insert' method

(cl-defgeneric jupyter-insert (_mime _data &optional _metadata)
  "Insert MIME data in the current buffer.
Additions to this method should insert DATA assuming it has a
mime type of MIME. If METADATA is non-nil, it will be a property
list containing extra properties for inserting DATA such as
:width and :height for image mime types.

If MIME is considered handled, but does not insert anything in
the current buffer, return a non-nil value to indicate that MIME
has been handled."
  (ignore))

(cl-defmethod jupyter-insert ((plist cons) &optional metadata)
  "Insert the content contained in PLIST.
PLIST should be a property list that contains the key :data and
optionally the key :metadata. The value of :data shall be another
property list that contains MIME types as keys and their
representations as values. For each MIME type in
`jupyter-mime-types' call

    (jupyter-insert MIME (plist-get data MIME) (plist-get metadata MIME))

until one of the invocations inserts text into the current
buffer (tested by comparisons with `buffer-modified-tick') or
returns a non-nil value. When either of these cases occur, return
MIME. Note you may also call this method like

    (jupyter-insert data metadata)

Note on non-graphic displays, `jupyter-nongraphic-mime-types' is
used instead of `jupyter-mime-types'.

When no valid mimetype is present, a warning is shown."
  (cl-assert plist json-plist)
  ;; Allow for passing the data plist directly this allows for
  ;; (jupyter-insert data nil) to work
  (let* ((data (or (plist-get plist :data) plist))
         (metadata (if (eq data plist) metadata
                     (plist-get plist :metadata))))
    (when data
      (or (let ((tick (buffer-modified-tick)))
            (jupyter-loop-over-mime (if (display-graphic-p) jupyter-mime-types
                                      jupyter-nongraphic-mime-types)
                mime data metadata
              (and (or (jupyter-insert mime data metadata)
                       (/= tick (buffer-modified-tick)))
                   mime)))
          (prog1 nil
            (warn "No valid mimetype found %s"
                  (cl-loop for (k _v) on data by #'cddr collect k)))))))

;;; HTML

(defun jupyter--shr-put-image (spec alt &optional flags)
  "Identical to `shr-put-image', but ensure :ascent is 50.
SPEC, ALT and FLAGS have the same meaning as in `shr-put-image'.
The :ascent of an image is set to 50 so that the image center
aligns on the current line."
  (let ((image (shr-put-image spec alt flags)))
    (prog1 image
      (when image
        ;; Ensure we use an ascent of 50 so that the image center aligns with
        ;; the output prompt of a REPL buffer.
        (setf (image-property image :ascent) 50)
        (force-window-update)))))

(defun jupyter--delete-javascript-tags ()
  (while (re-search-forward "<script type='text/javascript'>" nil t)
    (delete-region
     (match-beginning 0)
     (progn
       (re-search-forward "</script>")
       (point)))))

(defun jupyter-insert-html (html)
  "Parse and insert the HTML string using `shr'."
  (cl-letf (((symbol-function #'libxml-parse-html-region)
             ;; Be strict about syntax. Specifically `libxml-parse-html-region'
             ;; converts camel cased tags/attributes such as viewBox to viewbox
             ;; in the dom since html is case insensitive. See #4.
             #'libxml-parse-xml-region)
            (shr-put-image-function #'jupyter--shr-put-image)
            (beg (point)))
    (insert html)
    (save-restriction
      (narrow-to-region beg (point))
      (goto-char (point-min))
      ;; TODO: We can't really do much about javascript so
      ;; delete those regions instead of trying to parse
      ;; them. Maybe just re-direct to a browser like with
      ;; widgets?
      ;; NOTE: Parsing takes a very long time when the text
      ;; is > ~500000 characters.
      (jupyter--delete-javascript-tags)
      (shr-render-region (point-min) (point-max))
      (jupyter-add-font-lock-properties (point-min) (point-max)))))

;;; Markdown

(defvar markdown-hide-markup)
(defvar markdown-hide-urls)
(defvar markdown-fontify-code-blocks-natively)
(defvar markdown-mode-mouse-map)

(defvar jupyter-markdown-mouse-map
  (let ((map (make-sparse-keymap)))
    (define-key map [return] 'jupyter-markdown-follow-link-at-point)
    (define-key map [follow-link] 'mouse-face)
    (define-key map [mouse-2] 'jupyter-markdown-follow-link-at-point)
    map)
  "Keymap when `point' is over a markdown link in the REPL buffer.")

(cl-defgeneric jupyter-markdown-follow-link (_link-text _url _ref-label _title-text _bang)
  "Follow the markdown link at `point'."
  (markdown-follow-link-at-point))

(defun jupyter-markdown-follow-link-at-point ()
  "Handle markdown links specially."
  (interactive)
  (let ((link (markdown-link-at-pos (point))))
    (when (car link)
      (apply #'jupyter-markdown-follow-link (cddr link)))))

(defun jupyter-insert-markdown (text)
  "Insert TEXT, fontifying it using `markdown-mode' first."
  (let ((beg (point)))
    (insert
     (let ((markdown-hide-markup t)
           (markdown-hide-urls t)
           (markdown-fontify-code-blocks-natively t))
       (jupyter-fontify-according-to-mode 'markdown-mode text)))
    ;; Update keymaps
    (let ((end (point)) next)
      (setq beg (next-single-property-change beg 'keymap nil end))
      (while (/= beg end)
        (setq next (next-single-property-change beg 'keymap nil end))
        (when (eq (get-text-property beg 'keymap) markdown-mode-mouse-map)
          (put-text-property beg next 'keymap jupyter-markdown-mouse-map))
        (setq beg next)))))

;;; LaTeX

(defvar org-format-latex-options)
(defvar org-preview-latex-image-directory)
(defvar org-babel-jupyter-resource-directory)
(defvar org-preview-latex-default-process)

(defun jupyter-insert-latex (tex)
  "Generate and insert a LaTeX image based on TEX.

Note that this uses `org-format-latex' to generate the LaTeX
image."
  ;; FIXME: Getting a weird error when killing the temp buffers created by
  ;; `org-format-latex'. When generating the image, it seems that the temp
  ;; buffers created have the same major mode and local variables as the REPL
  ;; buffer which causes the query function to ask to kill the kernel client
  ;; when the temp buffers are killed!
  (let ((kill-buffer-query-functions nil)
        (org-format-latex-options
         `(:foreground
           default
           :background default :scale 2.0
           :matchers ,(plist-get org-format-latex-options :matchers)))
        (beg (point-marker))
        (end (point-marker)))
    (set-marker-insertion-type end t)
    (insert tex)
    (org-format-latex
     org-preview-latex-image-directory
     beg end org-babel-jupyter-resource-directory
     'overlays "Creating LaTeX image...%s"
     'forbuffer
     ;; Use the default method for creating image files
     org-preview-latex-default-process)
    (goto-char end)
    (set-marker beg nil)
    (set-marker end nil)))

;;; Images

(defun jupyter-insert-image (data type &optional metadata)
  "Insert image DATA as TYPE in the current buffer.
TYPE has the same meaning as in `create-image'. METADATA is a
plist containing :width and :height keys that will be used as the
width and height of the image."
  (cl-destructuring-bind (&key width height &allow-other-keys) metadata
    (let ((img (create-image data type 'data :width width :height height)))
      (insert-image img))))

;;; Plain text

(defun jupyter-insert-ansi-coded-text (text)
  "Insert TEXT, converting ANSI color codes to font lock faces."
  (jupyter-with-insertion-bounds
      beg end (insert (ansi-color-apply text))
    (jupyter-fixup-font-lock-properties beg end)))

;;; `jupyter-insert' method additions

(cl-defmethod jupyter-insert ((_mime (eql :text/html)) data
                              &context ((functionp 'libxml-parse-html-region)
                                        (eql t))
                              &optional _metadata)
  (jupyter-insert-html data)
  (insert "\n"))

(cl-defmethod jupyter-insert ((_mime (eql :text/markdown)) data
                              &context ((require 'markdown-mode nil t)
                                        (eql markdown-mode))
                              &optional _metadata)
  (jupyter-insert-markdown data))

(cl-defmethod jupyter-insert ((_mime (eql :text/latex)) data
                              &context ((require 'org nil t)
                                        (eql org))
                              &optional _metadata)
  (jupyter-insert-latex data)
  (insert "\n"))

(cl-defmethod jupyter-insert ((_mime (eql :image/svg+xml)) data
                              &context ((and (image-type-available-p 'svg) t)
                                        (eql t))
                              &optional metadata)
  (jupyter-insert-image data 'svg metadata)
  (insert "\n"))

(cl-defmethod jupyter-insert ((_mime (eql :image/jpeg)) data
                              &context ((and (image-type-available-p 'jpeg) t)
                                        (eql t))
                              &optional metadata)
  (jupyter-insert-image (base64-decode-string data) 'jpeg metadata)
  (insert "\n"))

(cl-defmethod jupyter-insert ((_mime (eql :image/png)) data
                              &context ((and (image-type-available-p 'png) t)
                                        (eql t))
                              &optional metadata)
  (jupyter-insert-image (base64-decode-string data) 'png metadata)
  (insert "\n"))

(cl-defmethod jupyter-insert ((_mime (eql :text/plain)) data
                              &optional _metadata)
  (jupyter-insert-ansi-coded-text data)
  (insert "\n"))

;;; Insert with display IDs

;; FIXME: The support for display IDs has not really been tested.

(cl-defmethod jupyter-insert :before ((_display-id string) &rest _)
  "Initialize `juptyer-display-ids'"
  ;; FIXME: Set the local display ID hash table for the current buffer, or
  ;; should display IDs be global? Then we would have to associate marker
  ;; positions as well in this table.
  (unless jupyter-display-ids
    (setq jupyter-display-ids (make-hash-table
                               :test #'equal
                               :weakness 'value))))

(cl-defmethod jupyter-insert ((display-id string) data &optional metadata)
  "Associate DISPLAY-ID with DATA when inserting DATA.
DATA and METADATA have the same meaning as in
`jupyter-insert'.

The default implementation adds a jupyter-display text property
to any inserted text and a jupyter-display-begin property to the
first character.

Currently there is no support for associating a DISPLAY-ID if
DATA is displayed as a widget."
  (jupyter-with-insertion-bounds
      beg end (jupyter-insert data metadata)
    ;; Don't add display IDs to widgets since those are currently implemented
    ;; using an external browser and not in the current buffer.
    (when (and (not (memq :application/vnd.jupyter.widget-view+json data))
               (< beg end))
      (let ((id (gethash display-id jupyter-display-ids)))
        (unless id
          (setq id (puthash display-id display-id jupyter-display-ids)))
        (put-text-property beg end 'jupyter-display id)
        (put-text-property beg (1+ beg) 'jupyter-display-begin t)))))

(provide 'jupyter-mime)

;;; jupyter-mime.el ends here