From 9f135bd5e8e153323bed5a3274851fa78f246b83 Mon Sep 17 00:00:00 2001 From: Bruno BARBIER Date: Fri, 16 Feb 2024 14:32:00 +0100 Subject: [PATCH 2/8] ob-core async: Add org-babel--async tools [2/5] --- lisp/ob-core.el | 213 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 213 insertions(+) diff --git a/lisp/ob-core.el b/lisp/ob-core.el index bfeac257b..d98626fe8 100644 --- a/lisp/ob-core.el +++ b/lisp/ob-core.el @@ -792,6 +792,219 @@ (defun org-babel-session-buffer (&optional info) (when (org-babel-comint-buffer-livep buffer-name) buffer-name))) +(defun org-babel--async-status-face (status) + (pcase status + (:scheduled 'org-async-scheduled) + (:pending 'org-async-pending) + (:failure 'org-async-failure) + (:success nil) + (_ (error "Not a status")) + )) + +(defun org-babel--async-make-overlay (beg end) + "Create an overlay between positions BEG and END and return it." + (let ((overlay (make-overlay beg end)) + (read-only + (list + (lambda (&rest _) + (user-error + "Cannot modify an area being updated")))) + ) + (cl-flet ((make-read-only + (ovl) + (overlay-put ovl 'modification-hooks read-only) + (overlay-put ovl 'insert-in-front-hooks read-only) + (overlay-put ovl 'insert-behind-hooks read-only)) + ) + (overlay-put overlay 'org-babel--async-type 'org-babel--async-note) + (overlay-put overlay 'face 'secondary-selection) + (overlay-put overlay 'help-echo "Pending src block result...") + (make-read-only overlay) + overlay))) + +(defun org-babel--async-result-region (inline-elem &optional info) + "Return the region of the results, for the source block at point." + (unless info (setq info (org-babel-get-src-block-info))) + (save-excursion + (when-let ((res-begin (org-babel-where-is-src-block-result nil info))) + (cons res-begin + (save-excursion + (goto-char res-begin) + (if inline-elem + ;; Logic copy/pasted from org-babel-where-is-src-block-result. + (let ((result (org-element-context))) + (and (org-element-type-p result 'macro) + (string= (org-element-property :key result) + "results") + (progn + (goto-char (org-element-end result)) + (skip-chars-backward " \t") + (point)))) + ;; Logic copy/pasted from hide-result + (beginning-of-line) + (let ((case-fold-search t)) + (unless (re-search-forward org-babel-result-regexp nil t) + (error "Not looking at a result line"))) + (org-babel-result-end) + )))))) + +(defun org-babel--async-feedbacks (info handle-result + result-params exec-start-time) + "Flag the result as \='scheduled\=' and return how to handle feedbacks. + +Use overlays to report progress and status to the user. Do not delete +the existing result unless a new one is available. When the result is +available, remove the async overlays and insert the result as usual, +like for a synchronous result. In case of failure, use an overlay to +report the error. + +The returned function handles 3 types of feedbacks: + - (:success R): Evaluation is successful; result is R. + - (:failure ERR): Evaluation failed; error is ERR. + - (:pending P): Outcome still pending; current progress is P." + ;; FIXME: INFO CMD ... Nothing is used but handle-result here !! + (let (;; copy/pasted from org-babel-insert-result + (inline-elem (let ((context (org-element-context))) + (and (memq (org-element-type context) + '(inline-babel-call inline-src-block)) + context)))) + (cl-labels + ((eot-point (start) + "Move to End Of Title after START" + (if inline-elem + (org-element-end inline-elem) + (save-excursion (goto-char start) + (forward-line 1) (point)))) + (after-indent (pt) + "Move after indentation, starting at PT." + (save-excursion (goto-char pt) (re-search-forward "[[:blank:]]*"))) + (mk-result-overlays () + ;; Make 2 overlays to handle the pending result: one title + ;; (first line) and one for the body. + (pcase-let ((`(,start . ,end) (org-babel--async-result-region + inline-elem info))) + (let ((anchor-end (eot-point start))) + (cons (org-babel--async-make-overlay + (after-indent start) + (1- anchor-end)) + (org-babel--async-make-overlay + anchor-end end))))) + (add-style (status txt) + ;; Add the style matching STATUS over the text TXT. + (propertize txt 'face (org-babel--async-status-face status))) + + (short-version-of (msg) + ;; Compute the short version of MSG, to display in the header. + ;; Must return a string. + (if msg + (car (split-string (format "%s" msg) "\n" :omit-nulls)) + "")) + (update (ovl-title status msg) + ;; Update the title overlay to match STATUS and MSG. + (overlay-put ovl-title + 'face + (org-babel--async-status-face status)) + (overlay-put ovl-title + 'before-string (pcase status + (:scheduled "⏱") + (:pending "⏳") + (:failure "❌") + (:success "✔️"))) + (overlay-put ovl-title + 'after-string + (propertize (format " |%s|" + (if (eq :failure status) + (if (consp msg) (car msg) + (format "%s" msg)) + (short-version-of msg))) + 'face (org-babel--async-status-face status)))) + (remove-previous-overlays () + ;; Remove previous title and body overlays. + (mapc (lambda (ovl) + (when (eq 'org-babel--async-note + (overlay-get ovl 'org-babel--async-type)) + (delete-overlay ovl))) + (when-let ((region (org-babel--async-result-region + inline-elem info))) + ;; Not sure why, but we do need to start before + ;; point min, else, in some cases, some overlays + ;; are not found. + (overlays-in (max (1- (car region)) (point-min)) + (cdr region)))))) + + (remove-previous-overlays) + + ;; Ensure there is a non-empty region for the result. + (save-excursion + (unless (org-babel-where-is-src-block-result (not inline-elem) nil nil) + (org-babel-insert-result + ;; Use " " for the empty result. That cannot be nil, else it's interpreted + ;; as a list. We need at least one char, to separate markers if any. + " \n" + result-params + info nil + (nth 0 info) ; lang + exec-start-time + ))) + + ;; Create the overlays that span the result title and its body. + (pcase-let ((`(,title-ovl . ,body-ovl) (mk-result-overlays))) + ;; Flag the result as ":scheduled". + (update title-ovl :scheduled nil) + + ;; The callback, that runs in the org buffer at point. + (let ((buf (current-buffer)) + (pt (point-marker))) + (lambda (feedback) + (message "ob-core: Handling outcome at %s@%s: %s" pt buf feedback) + (with-current-buffer buf + (save-excursion + (goto-char pt) + (pcase feedback + (`(:success ,r) + ;; Visual beep that the result is available. + (update title-ovl :success r) + (sit-for 0.2) + ;; We remove all overlays and let org insert the result + ;; as it would in the synchronous case. + (delete-overlay title-ovl) + (delete-overlay body-ovl) + (funcall handle-result r)) + + (`(:pending ,r) + ;; Still waiting for the outcome. Update our + ;; overlays with the progress info R. + (message "Updating block at %s@%s" pt buf) + (update title-ovl :pending r)) + + (`(:failure ,err) + ;; We didn't get a result. We update our overlays + ;; to report that failure. And unlock the old + ;; result. + (overlay-put title-ovl 'face nil) + (update title-ovl :failure err) + (delete-overlay body-ovl)) + + (_ (error "Invalid outcome")) + ) + )) + nil)))))) + + +(cl-defun org-babel--async-p (params &key default) + "Return a non-nil value when the execution is asynchronous. +Get the value of the :nasync argument and convert it." + (if-let ((binding (assq :nasync params))) + (pcase (cdr binding) + ((pred (not stringp)) + (error "Invalid value for :nasync argument")) + ((or "no" "n") nil) + ((or "yes" "y") t) + (_ (error "Invalid value for :nasync argument"))) + default)) + + + ;;;###autoload (defun org-babel-execute-src-block (&optional arg info params executor-type) "Execute the current source code block and return the result. -- 2.43.0