;;; ein-output-area.el --- Output area module ;; Copyright (C) 2012 Takafumi Arakaki ;; Author: Takafumi Arakaki ;; This file is NOT part of GNU Emacs. ;; ein-output-area.el 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. ;; ein-output-area.el 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 ein-output-area.el. ;; If not, see . ;;; Commentary: ;; ;;; Code: (require 'xml) (require 'shr) (require 'ein-core) (defvar ein:output-area-case-types '(:image/svg+xml :image/png :image/jpeg :text/plain :text/html :application/latex :application/tex :application/javascript) "Prefer :text/plain. Unless it's a single line \"\" or \"TemporalData[TimeSeries, <<1>>]\" in which case prefer :text/html.") (defcustom ein:output-area-inlined-images nil "Turn on to insert images into buffer. Default spawns external viewer." :type 'boolean :group 'ein) (defcustom ein:output-area-inlined-image-properties '(:foreground "black" :background "white") "Additional properties for inlined images. This is passed to `create-image' for some supported image types, such as SVG ones whose foregrounds are taken from the current frame by default and may appear unreadable." :type '(plist :value-type color) :group 'ein) (defcustom ein:shr-env '((shr-table-horizontal-line ?-) (shr-table-vertical-line ?|) (shr-table-corner ?+)) "Variables let-bound while calling `shr-insert-document'. To use default shr setting: (setq ein:shr-env nil) Draw boundaries for table (default): (setq ein:shr-env \\='((shr-table-horizontal-line ?-) (shr-table-vertical-line ?|) (shr-table-corner ?+))) " :type '(sexp) :group 'ein) ;;; XML/HTML utils (defun ein:xml-parse-html-string (html-string) "Parse HTML-STRING and return a dom object which can be handled by the xml module." (with-temp-buffer (insert html-string) (when (fboundp 'libxml-parse-html-region) (cl-loop with result repeat 3 do (setq result (libxml-parse-html-region (point-min) (point-max))) until result finally return result)))) (defalias 'ein:xml-node-p 'listp) (defun ein:xml-tree-apply (dom operation) "Apply OPERATION on nodes in DOM. Apply the same OPERATION on the next level children when it returns `nil'." (cl-loop for child in (xml-node-children dom) if (and (not (funcall operation child)) (ein:xml-node-p child)) do (ein:xml-tree-apply child operation))) (defun ein:xml-replace-attributes (dom tag attr replace-p replacer) "Replace value of ATTR of TAG in DOM using REPLACER when REPLACE-P returns non-`nil'." (ein:xml-tree-apply dom (lambda (node) (ein:and-let* (((ein:xml-node-p node)) ((eq (xml-node-name node) tag)) (attr-cell (assoc attr (xml-node-attributes node))) (val (cdr attr-cell)) ((funcall replace-p val))) (setcdr attr-cell (funcall replacer val)) t)))) (defun ein:output-area-get-html-renderer () (if (fboundp 'libxml-parse-xml-region) #'ein:insert-html-shr #'ein:insert-read-only)) (defun ein:shr-insert-document (dom) "`shr-insert-document' with EIN setting." (eval `(let ,ein:shr-env (shr-insert-document dom)))) (defun ein:insert-html-shr (html-string) "Render HTML-STRING using `shr-insert-document'. Usage:: (ein:insert-html-shr \"HTML string\") " (let ((dom (ein:xml-parse-html-string html-string)) (start (point)) end (buffer-undo-list t)) (ein:insert-html--fix-urls dom) (ein:shr-insert-document dom) (setq end (point)) (put-text-property start end 'read-only t) (put-text-property start end 'front-sticky t))) (defun ein:insert-html--fix-urls (dom &optional url-or-port) "Destructively prepend notebook server URL to local URLs in DOM." (ein:and-let* ((url-or-port (or url-or-port (ein:get-url-or-port))) (replace-p (lambda (val) (string-match-p "^/?files/" val))) (replacer (lambda (val) (ein:url url-or-port val)))) (ein:xml-replace-attributes dom 'a 'href replace-p replacer) (ein:xml-replace-attributes dom 'img 'src replace-p replacer))) (defun ein:output-area-type (mime-type) "Investigate why :image/svg+xml to :svg and :text/plain to :text" (let* ((mime-str (if (symbolp mime-type) (symbol-name mime-type) mime-type)) (minor-kw (car (nreverse (split-string mime-str "/")))) (minor (car (nreverse (split-string minor-kw ":"))))) (intern (concat ":" (cond ((string= minor "plain") "text") (t (cl-subseq minor 0 (cl-search "+" minor)))))))) (defun ein:output-area-convert-mime-types (json data) (let ((known-mimes (cl-remove-if-not #'identity (mapcar (lambda (x) (intern-soft (concat ":" x))) (mailcap-mime-types))))) (mapc (lambda (x) (-when-let* ((mime-val (plist-get data x)) (minor-kw (ein:output-area-type x))) (setq json (plist-put json minor-kw mime-val)))) known-mimes) json)) (defmacro ein:output-area-case-type (json &rest case-body) `(let* ((types (cl-copy-list ein:output-area-case-types)) (heuristic-p (and (memq :text/plain types) (memq :text/html types))) (,json (or (plist-get ,json :data) ,json)) (plain (plist-get ,json :text/plain)) (html (plist-get ,json :text/html))) (when (and heuristic-p (stringp plain) (< (length plain) 60) (stringp html) (> (length html) 300)) (delq :text/plain types)) (seq-some (lambda (type) (when-let ((value (plist-get ,json type))) ,@case-body t)) types))) (provide 'ein-output-area) ;;; ein-output-area.el ends here