From 49f3c562cd6a0fbe8efd29aee5230b70fb8d0473 Mon Sep 17 00:00:00 2001 From: Nathaniel Nicandro Date: Sun, 17 Nov 2024 16:18:22 -0600 Subject: [PATCH] Highlight ANSI escape sequences * etc/ORG-NEWS: Describe the new feature. * lisp/org.el (org-fontify-ansi-sequences): New customization variable and function which does the work of fontifying the sequences. (org-ansi-highlightable-elements) (org-ansi-highlightable-objects) (org-ansi-hide-sequences): New customization variables. (org-ansi-context, org-ansi-ansi-color-context): New variables. (org-ansi-new-context, org-ansi-copy-context, org-ansi-null-context-p) (org-ansi-clear-context, org-ansi-pack-context) (org-ansi-unpack-to-context, org-ansi-context-contained-p) (org-ansi-previous-context-position) (org-ansi-previous-context, org-ansi-point-context) (org-ansi-greater-element-context) (org-ansi-highlightable-element-p) (org-ansi-extent-of-context) (org-ansi-widened-element-and-end) (org-ansi-apply-on-region) (org-ansi-extend-region) (org-ansi-process-region, org-ansi-process-object) (org-ansi-process-lines, org-ansi-process-lines-consider-objects) (org-ansi-process-element) (org-ansi-visit-elements) (org-toggle-ansi-display): New functions. (org-set-font-lock-defaults): Add the `org-fontify-ansi-sequences` function to the font-lock keywords. (org-unfontify-region): Remove the `org-ansi-context` property. (org-ansi-mode): New minor mode to enable/disable highlighting of the sequences. Enable it in Org buffers by default. * testing/lisp/test-org.el (faceup): New require. (test-org/ansi-sequence-fontification): (test-org/ansi-sequence-editing): New tests. --- etc/ORG-NEWS | 17 + lisp/org.el | 698 ++++++++++++++++++++++++++++++++++++++- testing/lisp/test-org.el | 313 ++++++++++++++++++ 3 files changed, 1027 insertions(+), 1 deletion(-) diff --git a/etc/ORG-NEWS b/etc/ORG-NEWS index 92bfe35..cd875a8 100644 --- a/etc/ORG-NEWS +++ b/etc/ORG-NEWS @@ -76,6 +76,23 @@ now have diary timestamps included as well. # We list the most important features, and the features that may # require user action to be used. +*** ANSI escape sequences are now highlighted in the whole buffer + +A new customization ~org-fontify-ansi-sequences~ is available which +tells Org to highlight all ANSI sequences in the buffer if non-nil and +the new minor mode ~org-ansi-mode~ is enabled. + +To disable highlighting of the sequences you can either +disable ~org-ansi-mode~ or set ~org-fontify-ansi-sequences~ to ~nil~ +and =M-x org-mode-restart RET=. Doing the latter will disable +highlighting of sequences in all newly opened Org buffers whereas +doing the former disables highlighting locally to the current buffer. + +The visibility of the ANSI sequences is controlled by the new +customization ~org-ansi-hide-sequences~ which, if non-nil, makes the +regions containing the sequences invisible. The visibility can be +toggled with =M-x org-toggle-ansi-display RET=. + *** Alignment of image previews can be customized This is not a new feature. It has been added in Org 9.7, but not diff --git a/lisp/org.el b/lisp/org.el index 1e90579..cca6f26 100644 --- a/lisp/org.el +++ b/lisp/org.el @@ -82,6 +82,7 @@ (require 'calendar) (require 'find-func) (require 'format-spec) (require 'thingatpt) +(require 'ansi-color) (condition-case nil (load (concat (file-name-directory load-file-name) @@ -3688,6 +3689,12 @@ (defcustom org-fontify-whole-block-delimiter-line t :group 'org-appearance :type 'boolean) +(defcustom org-fontify-ansi-sequences t + "Non-nil means to highlight ANSI escape sequences." + :group 'org-appearance + :type 'boolean + :package-version '(Org . "9.8")) + (defcustom org-highlight-latex-and-related nil "Non-nil means highlight LaTeX related syntax in the buffer. When non-nil, the value should be a list containing any of the @@ -5627,6 +5634,670 @@ (defun org-fontify-extend-region (beg end _old-len) (cons beg (or (funcall extend "end" "]" 1) end))) (t (cons beg end)))))) +(defcustom org-ansi-highlightable-elements + '(plain-list drawer headline inlinetask table + table-row paragraph example-block export-block fixed-width) + "A list of element types that will have ANSI sequences processed." + :type '(list (symbol :tag "Element Type")) + :package-version '(Org . "9.8") + :group 'org-appearance) + +(defcustom org-ansi-highlightable-objects + '(bold code export-snippet italic macro + strike-through table-cell underline verbatim) + "A list of object types that will have ANSI sequences processed." + :type '(list (symbol :tag "Object Type")) + :package-version '(Org . "9.8") + :group 'org-appearance) + +(defcustom org-ansi-hide-sequences nil + "Non-nil means Org hides ANSI sequences." + :type 'boolean + :package-version '(Org . "9.8") + :group 'org-appearance) + +(defvar org-ansi-context nil + "The ANSI color context for the buffer. +An Org ANSI context is the same as the FACE-VEC structure defined +in `ansi-color-context-region'.") +(make-variable-buffer-local 'org-ansi-context) + +(defun org-ansi-new-context () + "Return a new ANSI context. +See `org-ansi-context'." + (list (make-bool-vector 8 nil) nil nil)) + +(defun org-ansi-copy-context (context) + "Return a copy of CONTEXT. +See `org-ansi-context'." + (let ((basic-faces (make-bool-vector 8 nil))) + (bool-vector-union basic-faces (car context) basic-faces) + (list basic-faces + (cadr context) + (caddr context)))) + +(defun org-ansi-null-context-p (context) + "Return non-nil if CONTEXT does not set a face when applied to a region. +See `org-ansi-context'." + (and (zerop (bool-vector-count-population (car context))) + (null (cadr context)) + (null (caddr context)))) + +(defun org-ansi-clear-context (context) + "Destructively clear CONTEXT. +See `org-ansi-context'." + (let ((basic-faces (car context))) + ;; From `ansi-color--update-face-vec' + (bool-vector-intersection basic-faces #&8"\0" basic-faces) + (setcar (cdr context) nil) + (setcar (cddr context) nil))) + +(defun org-ansi-pack-context (context) + (pcase-let ((`(,bf ,fg ,bg) context)) + (logior + (ash (cl-loop + with x = 0 + for i from 0 to (1- (length bf)) + if (aref bf i) do (setq x (+ x (ash 1 i))) + finally return x) + (+ 25 25)) + (if fg + (logior (ash fg (+ 25 1)) + (ash 1 25)) + 0) + (if bg + (logior (ash bg 1) 1) + 0)))) + +(defun org-ansi-unpack-to-context (int) + (list + (apply #'bool-vector + (cl-loop + with mask = (ash 1 (+ 25 25)) + repeat 8 + collect (not (zerop (logand int mask))) + and do (cl-callf ash mask 1))) + (unless (zerop (logand (ash 1 25) int)) + (logand #xffffff (ash int (- (+ 25 1))))) + (unless (zerop (logand 1 int)) + (logand #xffffff (ash int -1))))) + +(defun org-ansi-context-contained-p (a b) + (let ((get + (lambda (color int) + (when (eq color 'fg) + (cl-callf ash int -25)) + (unless (zerop (logand 1 int)) + (logand #xffffff (ash int -1)))))) + (or (let ((bf-mask (ash #xff (+ 25 25)))) + (not (zerop (logand (logand a bf-mask) + (logand b bf-mask))))) + (let ((fg-a (funcall get 'fg a))) + (and fg-a (eq fg-a (funcall get 'fg b)))) + (let ((bg-a (funcall get 'bg a))) + (and bg-a (eq bg-a (funcall get 'bg b))))))) + +;; TODO: Is this actually correct? The (1- pos) has me doubting it. +(defun org-ansi-previous-context-position (limit) + (let ((pos (point)) context) + (while (and (< limit pos) + (null context)) + (setq context (get-text-property + (max (1- pos) (point-min)) 'org-ansi-context) + pos (previous-single-property-change + pos 'org-ansi-context nil limit))) + (when context + pos))) + +(defun org-ansi-previous-context (pos limit) + (let ((pos (save-excursion + (goto-char pos) + (org-ansi-previous-context-position limit)))) + (when pos + (get-text-property pos 'org-ansi-context)))) + +(defun org-ansi-point-context () + "Return the ANSI context associated with `point'. +If no context is associated with `point' return nil." + (when-let ((packed-context + (let ((el (org-element-at-point))) + ;; A region AB where there is a context at the end of + ;; A, but no context anywhere in B will result in that + ;; ending context of A being picked up here by + ;; `org-ansi-previous-context' since that function + ;; finds the first non-null context between POS and + ;; LIMIT. Since B has no context and A ends in a + ;; context, it must be that A ends in an effectively + ;; null context (i.e. no foreground or background) + ;; which is just the implicit context on B so + ;; everything works out OK. + (or (org-ansi-previous-context (point) (org-element-begin el)) + (when-let ((parent (org-ansi-greater-element-context el))) + (org-ansi-previous-context + (org-element-begin el) + (org-element-contents-begin parent))))))) + (org-ansi-unpack-to-context packed-context))) + +(defvar org-element-greater-elements) + +(defun org-ansi-greater-element-context (el) + "Return non-nil if ANSI sequences in EL can span multiple elements. +They can if EL is contained in a greater element with a RESULTS +affiliated keyword. Or if EL is such a greater element. + +Specifically returns that greater element or nil." + (if (and (org-element-property :results el) + (memq (org-element-type el) org-ansi-highlightable-elements) + (memq (org-element-type el) org-element-greater-elements)) + el + (let ((parent el)) + (while (and parent + (not (eq (org-element-type parent) 'section)) + (not (org-element-property :results parent))) + (setq parent (org-element-parent parent))) + (when (and parent (not (eq parent el)) + (org-element-property :results parent) + (memq (org-element-type parent) + org-ansi-highlightable-elements)) + parent)))) + +(defun org-ansi-highlightable-element-p (el) + "Return non-nil if EL can have ANSI sequences highlighted in it. +See `org-ansi-highlightable-elements'." + (or (org-ansi-greater-element-context el) + (memq (org-element-type el) org-ansi-highlightable-elements))) + +(defun org-ansi-extent-of-context () + "Return the end of the influence of the ANSI context at `point'. +Return nil if `point' has no ANSI context." + (when-let ((context (get-text-property (point) 'org-ansi-context))) + (let* ((el (org-element-at-point)) + (pos (next-single-property-change (point) 'org-ansi-context)) + (end (cadr (org-ansi-widened-element-and-end el)))) + (while (and (< pos end) + (let ((other (get-text-property pos 'org-ansi-context))) + (or (null other) + (eq context other) + (org-ansi-context-contained-p context other)))) + (setq pos (next-single-property-change pos 'org-ansi-context nil end))) + (unless (get-text-property pos 'org-ansi-context) + (setq pos (previous-single-property-change pos 'org-ansi-context))) + pos))) + +(defun org-ansi-widened-element-and-end (el) + (let* ((greater-el (org-ansi-greater-element-context el)) + (el (or greater-el el))) + (if-let ((parent (org-ansi-greater-element-context el))) + (list parent (org-element-contents-end parent)) + (list el (pcase (org-element-type el) + ((or `headline `inlinetask) + (org-element-contents-begin el)) + (_ + (or (org-element-contents-end el) + (org-element-end el)))))))) + +;; What will be set as the `ansi-color-context-region' below. +(defvar org-ansi-ansi-color-context (list nil (make-marker))) + +(defun org-ansi-apply-on-region (beg end &optional face-function seq-function) + "Apply ANSI sequences between (BEG END), maintain Org specific state. +Calls `ansi-color-apply-on-region' on the region between BEG and +END using FACE-FUNCTION as the `ansi-color-apply-face-function' +which defaults to a function prepends the face and adds an +`org-ansi-context' property to the highlighted regions. + +SEQ-FUNCTION is a function to apply to the ANSI sequences found +in the region. It is called with the bounds of the sequence as +arguments. It defaults to doing nothing on the sequences." + (setcar org-ansi-ansi-color-context org-ansi-context) + (move-marker (cadr org-ansi-ansi-color-context) beg) + (let ((ansi-color-context-region org-ansi-ansi-color-context) + (ansi-color-apply-face-function + (or face-function + (lambda (beg end face) + (when face + (font-lock-prepend-text-property beg end 'face face)) + (add-text-properties + beg end (list 'org-ansi-context + (org-ansi-pack-context org-ansi-context))))))) + (ansi-color-apply-on-region beg end t)) + (goto-char beg) + (while (re-search-forward ansi-color-control-seq-regexp end 'noerror) + (let ((beg (match-beginning 0)) + (end (point))) + (when seq-function + (funcall seq-function beg end)) + (dolist (ov (overlays-at beg)) + (when (and (= beg (overlay-start ov)) + (= end (overlay-end ov)) + (overlay-get ov 'invisible)) + ;; Assume this is the overlay added by + ;; `ansi-color-apply-on-region'. + (delete-overlay ov)))))) + +(defvar font-lock-beg) +(defvar font-lock-end) + +(defun org-ansi-extend-region () + (let ((old-end font-lock-end) + (end font-lock-end) + (changed nil)) + (save-excursion + ;; Extend due to deletions or modifications of sequences. + (goto-char font-lock-beg) + (while (< (point) end) + (let ((context (get-text-property (point) 'org-ansi-context)) + (seq-state (get-text-property (point) 'org-ansi))) + (if (and context seq-state) + (if (and (looking-at ansi-color-control-seq-regexp) + (eq (intern (buffer-substring-no-properties + (match-beginning 0) (match-end 0))) + seq-state)) + (goto-char (next-single-property-change + (point) 'org-ansi-context nil end)) + ;; Either a sequence was deleted or a sequence was + ;; replaced with some other sequence. Extend the + ;; region to include the extent of the changed + ;; sequence. + (let ((ctx-end (org-ansi-extent-of-context))) + (setq end (max end ctx-end)) + (goto-char ctx-end))) + (goto-char (next-single-property-change + (point) 'org-ansi-context nil end))))) + (unless (eq old-end end) + (goto-char end) + (unless (eq (point) (line-beginning-position)) + (forward-line)) + (setq font-lock-end (point) + changed t)) + ;; Extend due to splits of elements into multiple other + ;; elements. + (goto-char font-lock-end) + (skip-chars-forward " \r\n\t") + (let* ((el (org-element-at-point)) + ;; FIXME Consider elements like plain-list and table, we + ;; don't want to end up fontifying the whole plain-list + ;; or table if the highlighting can be determined to only + ;; be up to some point before the end, e.g. within a + ;; paragraph or table row. + (end (pcase (org-element-type el) + ((or `headline `inlinetask) + (org-element-contents-begin el)) + (_ + (org-element-end el))))) + ;; Move to the first highlight within the element if not + ;; already at one. + (unless (get-text-property (point) 'org-ansi-context) + (let ((next (next-single-property-change + (point) 'org-ansi-context nil end))) + (unless (eq next end) + (goto-char next)))) + (when (get-text-property (point) 'org-ansi-context) + (if (get-text-property (point) 'org-ansi) + (let ((seq-context + (progn + (org-ansi-clear-context org-ansi-context) + ;; Purely for the side effect of + ;; setting `org-ansi-context' + (org-ansi-apply-on-region + (point) + (next-single-property-change (point) 'org-ansi) + #'ignore) + (org-ansi-pack-context org-ansi-context))) + (context (get-text-property (point) 'org-ansi-context))) + (unless (eq seq-context context) + (setq font-lock-end (org-ansi-extent-of-context) + changed t))) + ;; Include the whole element for lack of a better way of + ;; determining when to stop. See FIXME above. Could just + ;; look for the next sequence in this element... + (setq font-lock-end end + changed t))))) + changed)) + +(defun org-ansi-process-region (beg end) + "Process ANSI sequences in the region (BEG END). +Use and update the value of `org-ansi-context' during the +processing." + (let* ((highlight-beg beg) + (set-seq-properties + (lambda (beg end) + (let ((seq (intern (buffer-substring-no-properties beg end)))) + (remove-text-properties highlight-beg beg '(org-ansi t)) + (setq highlight-beg end) + (add-text-properties + beg end (list 'invisible 'org-ansi + 'rear-nonsticky '(org-ansi) + 'org-ansi seq)) + (put-text-property beg end 'org-ansi-context + (or (get-text-property end 'org-ansi-context) + ;; Handle edge case that a sequence + ;; occurs at the end of the region + ;; being processed. + (org-ansi-pack-context org-ansi-context))))))) + (org-ansi-apply-on-region beg end nil set-seq-properties) + (remove-text-properties highlight-beg end '(org-ansi t)))) + +(defun org-ansi-process-object (obj) + "Highlight the ANSI sequences contained in OBJ." + (org-ansi-process-region + (point) + (or (org-element-contents-end obj) + (- (org-element-end obj) + (org-element-post-blank obj) + 1))) + (goto-char (org-element-end obj))) + +(defun org-ansi-process-lines (beg end) + "Highlight the ANSI sequences of the lines between BEG and END. +Exclude whitespace at the beginning of the lines." + (goto-char beg) + (while (< (point) end) + (org-ansi-process-region (point) (min end (line-end-position))) + (forward-line) + (skip-chars-forward " \t")) + (goto-char end)) + +(defvar org-element-all-objects) + +(defun org-ansi-process-lines-consider-objects (beg end) + "Highlight the ANSI sequences of the lines between BEG and END. +Consider objects when highlighting." + (goto-char beg) + (while (re-search-forward ansi-color-control-seq-regexp end 'noerror) + (goto-char (match-beginning 0)) + (let ((seq-end (match-end 0)) + (el (org-element-context))) + ;; If the context is empty and the current sequence lies in an + ;; object, relegate the effect of the sequence to the object. + (if (org-ansi-null-context-p org-ansi-context) + (let ((type (org-element-type el))) + (if (memq type org-element-all-objects) + (if (not (memq type org-ansi-highlightable-objects)) + (goto-char seq-end) + (org-ansi-process-object el) + (org-ansi-clear-context org-ansi-context) + (setq beg (point))) + (org-ansi-process-lines beg seq-end))) + (org-ansi-process-lines beg seq-end)) + (setq beg seq-end))) + (org-ansi-process-lines beg end)) + +(defun org-ansi-process-element (el &optional limit) + "Process ANSI sequences in EL up to LIMIT. +EL should be a lesser element or headline. If EL can't be +processed, move `point' to its end. Otherwise process the +element, i.e. highlight the ANSI sequences beginning at +`point' (assumed to be within EL) and ending at LIMIT or the end +of the element, whichever comes first. + +After a call to this function `point' will be at LIMIT or the +next element that comes after EL." + (pcase (org-element-type el) + ((or `headline `inlinetask) + (org-ansi-process-lines-consider-objects + (point) (line-end-position)) + (goto-char (org-element-contents-begin el))) + (`table-row + ;; NOTE Limit not used here since a row is a line and it doesn't + ;; seem to make sense to process only some of the cells in a row. + ;; Limit is usually a line beginning position anyways which is + ;; the end of a table row in the first place. + (if (eq (org-element-property :type el) 'rule) + (goto-char (org-element-end el)) + (let ((end-1 (1- (org-element-end el)))) + (while (< (point) end-1) + (let ((cell (org-element-context))) + (org-ansi-process-region + (org-element-contents-begin cell) + (org-element-contents-end cell)) + (goto-char (org-element-end cell)))) + (forward-char)))) + ((or `example-block `export-block `src-block) + (let ((beg (point)) + (end (save-excursion + (goto-char (org-element-end el)) + (skip-chars-backward " \t\r\n") + (line-beginning-position)))) + (setq limit (if limit (min end limit) + end)) + (org-ansi-process-lines beg limit) + (if (eq limit end) + (goto-char (org-element-end el)) + (goto-char limit)))) + (`fixed-width + (setq limit (if limit (min (org-element-end el) limit) + (org-element-end el))) + (while (< (point) limit) + (when (eq (char-after) ?:) + (forward-char) + (when (eq (char-after) ?\s) + (forward-char))) + (org-ansi-process-region (point) (line-end-position)) + (skip-chars-forward " \n\r\t"))) + (`paragraph + (let ((pend (1- (org-element-contents-end el))) beg end) + (setq limit (if limit (min pend limit) pend)) + ;; Compute the regions of the paragraph excluding inline + ;; source blocks or babel calls. + (push (point) beg) + (while (re-search-forward + "\\<\\(src\\|call\\)_[^ \t\n[{]+[{(]" limit t) + (let ((el (org-element-context))) + (when (memq (org-element-type el) + '(inline-src-block inline-babel-call)) + (push (org-element-begin el) end) + (goto-char (min (org-element-end el) limit)) + (push (point) beg)))) + (push limit end) + (setq beg (nreverse beg) + end (nreverse end)) + (while beg + (org-ansi-process-lines-consider-objects (pop beg) (pop end))) + (if (eq limit pend) + (goto-char (org-element-end el)) + (goto-char limit)))) + (_ + (goto-char (org-element-end el))))) + +(defun org-ansi-visit-elements (limit visitor) + "Visit highlightable elements between `point' and LIMIT with VISITOR. +LIMIT is supposed to be a hard limit which VISITOR should not +visit anything past it. + +VISITOR is a function that takes an element and LIMIT as +arguments. It is called for every highlightable lesser element +within the visited region. After being called it is expected +that `point' is moved past the visited element, to the next +element to potentially process, or to LIMIT, whichever comes +first." + (declare (indent 1)) + (let ((skip-to-end-p + (lambda (el) + (or (null (org-element-contents-begin el)) + (<= (org-element-contents-end el) + (point) + (org-element-end el)))))) + (while (< (point) limit) + (let* ((el (org-element-at-point)) + (type (org-element-type el))) + (pcase type + ;; Greater elements + ((or `item `center-block `quote-block `special-block + `dynamic-block `drawer `footnote-definition) + (if (funcall skip-to-end-p el) + (goto-char (org-element-end el)) + (goto-char (org-element-contents-begin el)) + (org-ansi-visit-elements + (min limit (org-element-contents-end el)) + visitor))) + (`property-drawer + (goto-char (org-element-end el))) + (`plain-list + (if (funcall skip-to-end-p el) + (goto-char (org-element-end el)) + (let ((end (min limit (org-element-end el)))) + (goto-char (org-element-contents-begin el)) + (while (< (point) end) + ;; Move to within the first item of a list. + (forward-char) + (let* ((item (org-element-at-point)) + (cbeg (org-element-contents-begin item))) + (when cbeg + (goto-char cbeg) + (org-ansi-visit-elements + (min limit (org-element-contents-end item)) + visitor)) + (when (< (point) limit) + (goto-char (org-element-end item))) + (skip-chars-forward " \t\n\r")))))) + (`table + (if (funcall skip-to-end-p el) + (goto-char (org-element-end el)) + (goto-char (org-element-contents-begin el)) + ;; Move to within the table-row of a table to continue + ;; processing it. + (forward-char))) + ((or `headline `inlinetask) + (if (funcall skip-to-end-p el) + (goto-char (org-element-end el)) + (if (org-ansi-highlightable-element-p el) + (funcall visitor el limit) + (goto-char (org-element-contents-begin el))))) + ((guard (org-ansi-highlightable-element-p el)) + (let ((visit t)) + ;; Move to the beginning of the highlightable region if not already + ;; within one. + (pcase (org-element-type el) + (`table-row + (if (eq (org-element-property :type el) 'rule) + (progn + (setq visit nil) + (goto-char (org-element-end el))) + (when (< (point) (org-element-contents-begin el)) + (goto-char (org-element-contents-begin el))))) + ((or `example-block `export-block `src-block) + (let ((start (save-excursion + (goto-char (org-element-post-affiliated el)) + (line-beginning-position 2)))) + (when (< (point) start) + (goto-char start)))) + (`fixed-width + (when (< (point) (org-element-post-affiliated el)) + (goto-char (org-element-post-affiliated el)))) + (`paragraph + (when (< (point) (org-element-contents-begin el)) + (goto-char (org-element-contents-begin el))))) + (when visit + ;; Move past any whitespace at the beginning of a line if + ;; `point' is within that whitespace. + (let ((pos (point)) + (skipped (not (zerop (skip-chars-backward " \t"))))) + (if (eq (point) (line-beginning-position)) + (skip-chars-forward " \t") + (when skipped + (goto-char pos)))) + (funcall visitor el limit)))) + (_ + (goto-char (org-element-end el)))))) + ;; Move to the next element when `point' is basically at the end + ;; of an element. + (let ((el (org-element-at-point))) + (when (and (org-element-contents-begin el) + (<= (org-element-contents-end el) + (point) + (org-element-end el))) + (goto-char (org-element-end el)))))) + +(defvar org-ansi-mode) + +(defun org-fontify-ansi-sequences (limit) + "Fontify ANSI sequences." + (when (and org-fontify-ansi-sequences org-ansi-mode) + (or org-ansi-context + (setq org-ansi-context (org-ansi-new-context))) + (org-ansi-clear-context org-ansi-context) + (let* ((last-el-processed nil) + (process + (lambda (el limit &optional context) + (when-let ((context (or context (org-ansi-point-context)))) + (setq org-ansi-context context)) + (pcase-let* ((`(,widened-el ,end) (org-ansi-widened-element-and-end el)) + ;; Preserve the context when processing a + ;; highlightable greater element or when + ;; the processing limit falls within an + ;; element. In both cases, the context may + ;; be needed for post processing. + (preserve-context (or (< limit end) + (not (eq widened-el el))))) + (org-ansi-visit-elements (min end limit) + (lambda (el limit) + (setq last-el-processed el) + (org-ansi-process-element el limit) + (unless preserve-context + (org-ansi-clear-context org-ansi-context)))))))) + (skip-chars-forward " \n\r\t") + (while (< (point) limit) + (let ((context (org-ansi-point-context))) + (cond + (context + ;; A context exists before point in this element so it + ;; must have been highlightable, process the element + ;; starting with the previous context. + (funcall process (org-element-at-point) limit context)) + (t + ;; No previous context at this point, so it's safe to + ;; begin processing at the start of the next sequence. + ;; There is no context prior to the sequence to consider. + (when (re-search-forward ansi-color-control-seq-regexp limit 'noerror) + (goto-char (match-beginning 0)) + (funcall process (org-element-at-point) limit))))) + (skip-chars-forward " \n\r\t")) + ;; Post processing to highlight to the proper end (past limit) + ;; when there is a non-null context remaining and the region + ;; after limit does not match with the context. + (pcase-let* ((el (org-element-at-point)) + (`(,widened-el ,end) (org-ansi-widened-element-and-end el))) + (when (and (not (org-ansi-null-context-p org-ansi-context)) + (or + ;; A partial processing of the element. `point' + ;; is still inside of it. + (eq last-el-processed el) + ;; Inside a highlightable greater element context. + ;; Processing ended at the end of an element and + ;; thus `point' will be at the beginning of the + ;; next element. If that next element is inside + ;; the same greater element context then the + ;; highlighting should continue through to that + ;; next element and beyond. + (and (not (eq widened-el el)) + (<= (org-element-contents-begin widened-el) (point) + (org-element-contents-end widened-el))))) + (let ((visit 'check)) + (catch 'visit + (org-ansi-visit-elements end + (lambda (el limit) + (when (eq visit 'check) + (let ((context (get-text-property + (point) 'org-ansi-context))) + (when (eq context + (org-ansi-pack-context org-ansi-context)) + ;; Only continue the highlighting past limit + ;; when the contexts don't match. + (throw 'visit nil))) + (setq visit t)) + (org-ansi-process-element el limit) + (when (eq widened-el el) + (org-ansi-clear-context org-ansi-context))))))))))) + +(defun org-toggle-ansi-display () + "Toggle the visible state of ANSI sequences in the current buffer." + (interactive) + (setq org-ansi-hide-sequences (not org-ansi-hide-sequences)) + (if org-ansi-hide-sequences + (add-to-invisibility-spec 'org-ansi) + (remove-from-invisibility-spec 'org-ansi))) + (defun org-activate-footnote-links (limit) "Add text properties for footnotes." (let ((fn (org-footnote-next-reference-or-definition limit))) @@ -5971,6 +6642,7 @@ (defun org-set-font-lock-defaults () ;; `org-fontify-inline-src-blocks' prepends object boundary ;; faces and overrides native faces. '(org-fontify-inline-src-blocks) + '(org-fontify-ansi-sequences) ;; Citations. When an activate processor is specified, if ;; specified, try loading it beforehand. (progn @@ -6159,7 +6831,7 @@ (defun org-unfontify-region (beg end &optional _maybe_loudly) (remove-text-properties beg end '(mouse-face t keymap t org-linked-text t invisible t intangible t - org-emphasis t)) + org-emphasis t org-ansi-context t)) (org-fold-core-update-optimisation beg end) (org-remove-font-lock-display-properties beg end))) @@ -15950,6 +16622,30 @@ (defun org-agenda-prepare-buffers (files) (when org-agenda-file-menu-enabled (org-install-agenda-files-menu)))) + +;;;; ANSI minor mode + +(define-minor-mode org-ansi-mode + "Toggle the minor `org-ansi-mode'. +This mode adds support to highlight ANSI sequences in Org mode. +The sequences are highlighted only if the customization +`org-fontify-ansi-sequences' is non-nil when the mode is enabled. +\\{org-ansi-mode-map}" + :lighter " OANSI" + (if org-ansi-mode + (progn + (add-hook 'font-lock-extend-region-functions + #'org-ansi-extend-region 'append t) + (if org-ansi-hide-sequences + (add-to-invisibility-spec 'org-ansi) + (remove-from-invisibility-spec 'org-ansi))) + (remove-hook 'font-lock-extend-region-functions + #'org-ansi-extend-region t) + (remove-from-invisibility-spec 'org-ansi)) + (org-restart-font-lock)) + +(add-hook 'org-mode-hook #'org-ansi-mode) + ;;;; CDLaTeX minor mode diff --git a/testing/lisp/test-org.el b/testing/lisp/test-org.el index 2487c9a..a376d90 100644 --- a/testing/lisp/test-org.el +++ b/testing/lisp/test-org.el @@ -28,6 +28,8 @@ (require 'org) (require 'org-inlinetask) (require 'org-refile) (require 'org-agenda) +(require 'faceup) + ;;; Helpers @@ -2253,6 +2255,317 @@ (ert-deftest test-org/clone-with-time-shift () (org-test-with-result 'buffer (org-clone-subtree-with-time-shift 1 "-2h"))))))) + +;;; ANSI sequences + +(ert-deftest test-org/ansi-sequence-fontification () + "Test correct behavior of ANSI sequences." + (let ((org-fontify-ansi-sequences t)) + (cl-labels + ((faceup + (text) + (org-test-with-temp-text text + (org-ansi-mode) + (font-lock-ensure) + (let ((fontified (current-buffer))) + (with-temp-buffer + (faceup-markup-to-buffer (current-buffer) fontified) + (buffer-string))))) + (test + (text text-faceup) + ;; Don't spill over sequences to the rest of the terminal + ;; when a test fails. + (setq text (concat text "\n\n") + text-faceup (concat text-faceup "\n\n")) + (should (faceup-test-equal (faceup text) text-faceup)))) + (cl-macrolet ((face (f &rest args) + (let* ((short-name (alist-get f faceup-face-short-alist)) + (name (or short-name f)) + (prefix (format (if short-name "%s:" "%S:") name))) + (unless short-name + (cl-callf2 concat ":" prefix)) + (cl-callf2 concat "«" prefix) + `(concat ,prefix ,@args "»"))) + (fg (&rest args) `(face (:foreground "green3") ,@args)) + (bg (&rest args) `(face (:background "green3") ,@args)) + (fg-bg (&rest args) `(fg (bg ,@args))) + (bold (&rest args) `(face bold ,@args)) + (org (text) `(faceup ,text)) + (fg-start () "") + (bg-start () "") + (clear () "")) + ;; Objects + ;; Sequence's effect remains in object... + (test + (concat "1 An *obj" (fg-start) "ect*. text after\n") + (concat "1 An " (bold "*obj" (fg-start) (fg "ect") "*") ". text after\n")) + ;; ...except when there were sequences at the element level previously. + (test + (concat "2 " (fg-start) "text *obj" (bg-start) "ect*. text after\n") + (concat "2 " (fg-start) (fg "text ") + (bold (fg "*obj") (bg-start) (fg-bg "ect*")) + (fg-bg ". text after") "\n")) + ;; Sequence in object before sequence at element level. + (test + (concat + "3 *obj" (fg-start) "ect*. text " + (bg-start) "after\n") + (concat + "3 " (bold "*obj" (fg-start) (fg "ect") "*") ". text " + (bg-start) (bg "after") "\n")) + ;; Clearing the ANSI context in a paragraph, resets things so + ;; that sequences appearing in objects later in the paragraph + ;; have their effects localized to the objects. + (test + (concat + "4 *obj" (fg-start) "ect* " (fg-start) " text" + (clear) " text *obj" (bg-start) "ect* more text\n") + (concat + "4 " (bold "*obj" (fg-start) (fg "ect") "*") " " (fg-start) (fg " text") + (clear) " text " (bold "*obj" (bg-start) (bg "ect") "*") " more text\n")) + ;; Tables + (test + (concat + "#+RESULTS:\n" + "| " (fg-start) "10a | b |\n" + "| c | d |\n") + (concat + (org "#+RESULTS:\n") + (face org-table "| " (fg-start) (fg "10a") " | " (fg "b") " |") (face org-table-row "\n") + (face org-table "| " (fg "c") " | " (fg "d") " |") (face org-table-row "\n"))) + (test + (concat + "| " (fg-start) "5a | b |\n" + "| cell | d |\n") + (concat + (face org-table "| " (fg-start) (fg "5a")" | " (fg "b") " |") (face org-table-row "\n") + (face org-table "| cell" " | d |") (face org-table-row "\n"))) + ;; Paragraphs + (test + (concat + (fg-start) "6 paragraph1\ntext\n" + "\nparagraph2\n\n" + (fg-start) "text src_python{return 1 + 1} " + (bg-start) "more text\n") + (concat + (fg-start) (fg "6 paragraph1") "\n" + (fg "text") "\n" + "\nparagraph2\n\n" + ;; Effect of sequences skips inline source blocks. + (fg-start) (fg "text ") (org "src_python{return 1 + 1} ") + (bg-start) (fg (bg "more text")) "\n")) + ;; Don't fontify whitespace + ;; Fixed width + (test + (concat + "#+RESULTS:\n" + ": 4 one " (fg-start) "two\n" + ": three\n") + (concat + (org "#+RESULTS:\n") + (face org-code + ": 4 one " (fg-start) (fg "two") "\n" + ": " (fg "three") "\n"))) + ;; Blocks + (test + (concat + "#+begin_example\n" + "5 li " (fg-start) "ne 1\n" + "line 2\n" + "line 3\n" + "#+end_example\n" + "\ntext after\n") + (concat + (face org-block-begin-line "#+begin_example\n") + (face org-block + "5 li " (fg-start) (fg "ne 1") "\n" + (fg "line 2") "\n" + (fg "line 3") "\n") + (face org-block-end-line "#+end_example\n") + "\ntext after\n")) + ;; Avoid processing some elements according to + ;; `org-ansi-highlightable-elements' or + ;; `org-ansi-highlightable-objects'. + (let ((org-ansi-highlightable-objects + (delete 'verbatim org-ansi-highlightable-objects)) + (org-ansi-highlightable-elements + (delete 'src-block org-ansi-highlightable-elements))) + (test + (concat + "6 =verb" (fg-start) "atim=\n\n" + "#+begin_src python\n" + "return \"str " (fg-start) "ing\"\n" + "#+end_src\n") + (org + (concat + "6 =verb" (fg-start) "atim=\n\n" + "#+begin_src python\n" + "return \"str " (fg-start) "ing\"\n" + "#+end_src\n")))) + ;; Headlines + (test + (concat + "* 7 Head" (fg-start) "line 1\n" + "\ntext after\n") + (concat + (face org-level-1 "* 7 Head" (fg-start) (fg "line 1")) "\n" + "\ntext after\n")) + ;; Sequences span the whole list with a RESULTS affiliated + ;; keyword. + (test + (concat + "- " (fg-start) "one\n" + " - two\n" + "- three\n\n" + "#+RESULTS:\n" + "- " (fg-start) "one\n" + " - two\n" + "- three\n") + (concat + "- " (fg-start) (fg "one") "\n" + " - two\n" + "- three\n\n" + (org "#+RESULTS:\n") + "- " (fg-start) (fg "one") "\n" + " - " (fg "two") "\n" + "- " (fg "three") "\n")) + (test + (concat + "#+RESULTS:\n" + "| " (fg-start) "b | c |\n" + "|---+---|\n" + "| a | b |\n\n" + "paragraph1\n\n" + "-----\n\n" + "paragraph2\n") + (concat + (org "#+RESULTS:\n") + (face org-table "| " (fg-start) (fg "b") " | " (fg "c") " |") (face org-table-row "\n") + (face org-table "|---+---|") (face org-table-row "\n") + (face org-table "| " (fg "a") " | " (fg "b") " |") (face org-table-row "\n") + "\nparagraph1\n\n" + "-----\n\n" + "paragraph2\n")) + (test + (concat + "#+RESULTS:\n" + ":drawer:\n" + (fg-start) "paragraph\n\n" + "#+begin_center\n" + "- item1\n" + "- item2\n" + " - item3\n" + "#+end_center\n\n" + "paragraph2\n" + ":end:\n") + (concat + (org "#+RESULTS:\n") + (org ":drawer:\n") + (fg-start) (fg "paragraph") "\n\n" + (face org-block-begin-line "#+begin_center\n") + "- " (fg "item1") "\n" + "- " (fg "item2") "\n" + " - " (fg "item3") "\n" + (face org-block-end-line "#+end_center\n") "\n" + (fg "paragraph2") "\n" + (org ":end:\n"))) + ;; Highlighting context doesn't spill over to elements when it + ;; shouldn't. + (test + (concat + "#+BEGIN: dblock\n" + "- Item 1\n" + "- Item 2\n" + "- " (fg-start) "Item 3\n" + "#+END:\n\n" + "[fn:1] Footnote " (bg-start) "definition\n") + (concat + (face org-meta-line "#+BEGIN: dblock") "\n" + "- Item 1\n" + "- Item 2\n" + "- " (fg-start) (fg "Item 3") "\n" + (face org-meta-line "#+END:") "\n\n" + (face org-footnote "[fn:1]") " Footnote " (bg-start) (bg "definition") "\n")))))) + +(ert-deftest test-org/ansi-sequence-editing () + (cl-labels ((test (text-faceup) + (let ((fontified (current-buffer))) + (with-temp-buffer + (faceup-markup-to-buffer (current-buffer) fontified) + (should (faceup-test-equal (buffer-string) text-faceup))))) + (test-lines (n text-faceup &optional no-ensure) + (unless no-ensure + (font-lock-ensure (line-beginning-position) (1+ (line-end-position n)))) + (save-restriction + (narrow-to-region (line-beginning-position) (1+ (line-end-position n))) + (test text-faceup)))) + (cl-macrolet ((face (f &rest args) `(concat "«" ,(format ":%S:" f) ,@args "»")) + (fg (&rest args) `(face (:foreground "green3") ,@args)) + (fg-start () "") + (clear () "")) + ;; fixed-width regions and font-lock-multiline + (org-test-with-temp-text + (concat "\ +: " (fg-start) "line1 +: line2 +") + (org-ansi-mode) + (font-lock-ensure) + (insert ": line3\n") + (forward-line -1) + ;; Sequence effects spill over to newly inserted fixed-width line. + (test-lines 1 (face org-code ": " (fg "line3") "\n")) + (forward-line -1) + (goto-char (line-end-position)) + (insert "text") + ;; Editing a line that is affected by some previous line's + ;; sequence maintains the effect of that sequence on the + ;; line. + (test-lines 2 (face org-code + ": " (fg "line2text") "\n" + ": " (fg "line3") "\n"))) + ;; Test that the highlighting spans all nested elements inside + ;; an element with a RESULTS keyword and the highlighting + ;; remains after edits to any of the elements. + (org-test-with-temp-text + (concat "#+RESULTS:\n" + ":drawer:\n" + (fg-start) "paragraph\n\n" + "#+begin_center\n" + "- item1\n" + "- item2\n" + " - item3\n" + "#+end_center\n\n" + "paragraph2\n" + ":end:\n") + (org-ansi-mode) + (font-lock-ensure) + (insert "more text") + (test-lines 1 (concat (fg "paragraph2more text") "\n")) + (re-search-backward "item3") + (forward-char) + (insert "x") + (test-lines 1 (concat " - " (fg "ixtem3") "\n"))) + ;; Joining paragraphs takes into account highlighting. + (org-test-with-temp-text + (concat (fg-start) "paragraph1\n\nparagraph2\n") + (org-ansi-mode) + (font-lock-ensure) + (test-lines 1 "paragraph2\n") + (delete-char -1) + (test-lines 1 (concat (fg "paragraph2") "\n"))) + ;; Splits in a highlighted region remove highlighting from the + ;; region split. + (org-test-with-temp-text + (concat (fg-start) "line1\nline2\nline3\nline4\n") + (org-ansi-mode) + (font-lock-ensure) + (insert "\n") + ;; Test `org-ansi-extend-region' by limiting the region + ;; font-locked so it can be extended. + (font-lock-ensure (point) (1+ (line-end-position))) + (test-lines 2 "line3\nline4\n" t))))) + ;;; Fixed-Width Areas -- 2.41.0