branch: externals/futur
commit 1c6b5a310623383f749424656a9b46dca9043027
Author: Stefan Monnier <[email protected]>
Commit: Stefan Monnier <[email protected]>
Make `smerge-refine-regions` async; Fix problems in Emacs-30
* futur-client.el (futur--elisp-process-filter-stderr): Consult the
right process's property.
(futur--elisp-funcall-1): Work around bug#76643.
* futur-hacks.el (futur--smerge-refine-regions): New function.
(futur-hacks-mode): Use it.
(smerge--refine-prepare-regions, smerge--refine-apply-diff)
(smerge--refine-apply-diff-1): New fallback definitions.
* futur-server.el (futur--obarray-revert): Work around for Emacs<31.
* futur-tests.el (futur-process): Delete temp file.
(futur--tests-elisp-funcall): New function, extracted from
`futur-elisp-funcall` test. Make sure we don't try and return
a non-printable value.
(futur--elisp-funcall, futur-sandbox-funcall): Use it.
* futur.el (futur-unwind-protect): Fix macro expansion so unwind FORMS
are run even if an error occurs while evaluating FORM itself.
---
futur-client.el | 15 ++++-
futur-hacks.el | 176 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-
futur-server.el | 7 ++-
futur-tests.el | 72 +++++++----------------
futur.el | 2 +-
5 files changed, 215 insertions(+), 57 deletions(-)
diff --git a/futur-client.el b/futur-client.el
index 75e721e0ea..daea3a38f8 100644
--- a/futur-client.el
+++ b/futur-client.el
@@ -126,9 +126,11 @@ A server kind is a symbol.")
(while (string-match "\n" string)
(let* ((head (substring string 0 (match-beginning 0)))
(tail (substring string (match-end 0)))
- (line (if pending (concat pending head) head)))
+ (line (if pending (concat pending head) head))
+ (parent (process-get proc 'futur--parent))
+ (kind (if parent (process-get parent 'futur--kind) 'orphan)))
(unless (equal line "")
- (message "%s: %S" (process-get proc 'futur--kind) line))
+ (message "%s: %S" (or kind 'futur-unknown-kind) line))
(setq pending nil)
(setq string tail)))
(process-put proc 'futur--pending
@@ -171,6 +173,7 @@ A server kind is a symbol.")
"-Q" "--batch"
"-l" ,(locate-library "futur-server")
"-f" "futur-server"))))
+ (process-put stderr 'futur--parent proc)
(process-put proc 'futur--kind kind)
(process-put proc 'futur--state :booting)
(process-put proc 'futur--rid 0)
@@ -262,7 +265,13 @@ A server kind is a symbol.")
(defun futur--elisp-funcall-1 (futur-proc func args)
(futur-let*
((proc <- futur-proc)
- (rid (cl-incf (process-get proc 'futur--rid)))
+ (rid
+ ;; FIXME: In Emacs<31, cl-incf on process-get doesn't return
+ ;; the expected value.
+ ;; (cl-incf (process-get proc 'futur--rid))
+ (progn
+ (cl-incf (process-get proc 'futur--rid))
+ (process-get proc 'futur--rid)))
(_ (with-temp-buffer
;; (trace-values :funcall rid func args)
(process-put proc 'futur--ready nil)
diff --git a/futur-hacks.el b/futur-hacks.el
index c7fbbb5fef..7946842bb8 100644
--- a/futur-hacks.el
+++ b/futur-hacks.el
@@ -132,6 +132,177 @@ current buffer state and calls REPORT-FN when done."
(lambda ()
(delete-file temp-file))))))
+(defun futur--smerge-refine-regions (beg1 end1 beg2 end2 props-c &optional
preproc props-r props-a)
+ "Do it asynchronously."
+ (defvar smerge-refine-ignore-whitespace)
+ (defvar smerge-refine-weight-hack)
+ (declare-function smerge--refine-prepare-regions "smerge-mode")
+ (declare-function smerge--refine-apply-diff "smerge-mode")
+ ;; FIXME: Rate-limit with `futur-concurrency-bound'.
+ ;; FIXME: Check that the regions haven't changed/disappeared.
+ (pcase-let*
+ ((`(,file1 ,ol1 ,file2 ,ol2)
+ (smerge--refine-prepare-regions beg1 end1 beg2 end2
+ preproc props-c props-r props-a)))
+
+ ;; Call diff on those files.
+ (futur-with-temp-buffer
+ (let ((buf (current-buffer)))
+ (futur-let*
+ ((exitcode
+ <- (futur-unwind-protect
+ ;; Allow decoding the EOL format, as on MS-Windows the
+ ;; Diff utility might produce CR-LF EOLs.
+ (let ((coding-system-for-read 'utf-8-emacs))
+ ;; (trace-values :file1 (file-attributes file1))
+ ;; (trace-values :file2 (file-attributes file2))
+ (futur-process-call
+ diff-command nil buf nil
+ (if (and smerge-refine-ignore-whitespace
+ (not smerge-refine-weight-hack))
+ ;; Pass -a so diff treats it as a text file
+ ;; even if it contains \0 and such.
+ ;; Pass -d so as to get the smallest change, but
+ ;; also and more importantly because otherwise it
+ ;; may happen that diff doesn't behave like
+ ;; `smerge-refine-weight-hack' expects it to.
+ ;; See
https://lists.gnu.org/r/emacs-devel/2007-11/msg00401.html
+ "-awd" "-ad")
+ file1 file2))
+ (delete-file file1)
+ (delete-file file2))))
+ ;; (trace-values :process-exit exitcode)
+ ;; Process diff's output.
+ (when (and (overlay-buffer ol1) (overlay-buffer ol2))
+ (smerge--refine-apply-diff buf ol1 ol2
+ props-c props-r props-a)))))))
+
+(with-eval-after-load 'smerge-mode
+ (defvar smerge--refine-long-words)
+ (defvar smerge-refine-ignore-whitespace)
+ (defvar smerge-refine-weight-hack)
+ (declare-function smerge--refine-highlight-change "smerge-mode")
+ (declare-function smerge--refine-chopup-region "smerge-mode")
+ (declare-function smerge--refine-apply-diff-1 "ext:here-or-smerge-mode")
+
+ (unless (fboundp 'smerge--refine-prepare-regions) ;; Emacs-31
+ (defun smerge--refine-prepare-regions ( beg1 end1 beg2 end2
+ preproc props-c props-r props-a)
+ (let* ((file1 (make-temp-file "diff1"))
+ (file2 (make-temp-file "diff2"))
+ (smerge--refine-long-words
+ (if smerge-refine-weight-hack (make-hash-table :test #'equal)))
+
+ ;; Cover each region with an `smerge--refine-region' overlay.
+ (ol1 (make-overlay beg1 end1
+ (if (markerp beg1) (marker-buffer beg1))
+ 'front-advance nil))
+ (ol2 (make-overlay beg2 end2
+ (if (markerp beg2) (marker-buffer beg2))
+ 'front-advance nil))
+ (common-props
+ (let ((props '((evaporate . t) (smerge--refine-region . t))))
+ (dolist (prop (or props-a props-c))
+ (when (and (not (memq (car prop) '(face font-lock-face)))
+ (member prop (or props-r props-c))
+ (or (not (and props-c props-a props-r))
+ (member prop props-c)))
+ ;; This PROP is shared among all those overlays.
+ ;; Better keep it also for the `smerge--refine-region'
+ ;; overlays, so the client package recognizes them as
+ ;; being part of the refinement (e.g. it will hopefully
+ ;; delete them like the others).
+ (push prop props)))
+ props)))
+
+ (dolist (prop common-props)
+ (overlay-put ol1 (car prop) (cdr prop))
+ (overlay-put ol2 (car prop) (cdr prop)))
+
+ (let ((write-region-inhibit-fsync t)) ; Don't fsync temp files.
+ ;; Chop up regions into smaller elements and save into files.
+ (smerge--refine-chopup-region
+ (with-current-buffer (overlay-buffer ol1)
+ (copy-marker (overlay-start ol1)))
+ (overlay-end ol1) file1 preproc)
+ (smerge--refine-chopup-region
+ (with-current-buffer (overlay-buffer ol2)
+ (copy-marker (overlay-start ol2)))
+ (overlay-end ol2) file2 preproc))
+
+ `(,file1 ,ol1 ,file2 ,ol2))))
+
+ (unless (fboundp 'smerge--refine-apply-diff) ;; Emacs-31
+ (defun smerge--refine-apply-diff ( diffbuf ol1 ol2
+ props-c props-r props-a)
+ ;; `smerge--refine-apply-diff-1' isn't careful to preserve the
+ ;; position of point, so do it here.
+ (let ((pt1 (with-current-buffer (overlay-buffer ol1) (point)))
+ (pt2 (with-current-buffer (overlay-buffer ol2) (point))))
+ (unwind-protect
+ (smerge--refine-apply-diff-1 diffbuf ol1 ol2
+ props-c props-r props-a)
+ (with-current-buffer (overlay-buffer ol1)
+ (goto-char pt1)
+ ;; Usually ol1 and ol2 are in the same buffer, so `set-buffer'
+ ;; from ol1 to maximize the chance that it's a no-op.
+ (with-current-buffer (overlay-buffer ol2) (goto-char pt2))))))
+
+ (defun smerge--refine-apply-diff-1 ( diffbuf ol1 ol2
+ props-c props-r props-a)
+ (with-current-buffer diffbuf
+ (goto-char (point-min))
+ ;; (trace-values :starting1 (current-buffer) (buffer-size))
+ (let ((last1 nil)
+ (last2 nil)
+ (beg1 (with-current-buffer (overlay-buffer ol1)
+ (copy-marker (overlay-start ol1))))
+ (beg2 (with-current-buffer (overlay-buffer ol2)
+ (copy-marker (overlay-start ol2))))
+ (end1 (overlay-end ol1))
+ (end2 (overlay-end ol2)))
+ (while (not (eobp))
+ (if (not (looking-at
"\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?\\([acd]\\)\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?$"))
+ (error "Unexpected patch hunk header: %s"
+ (buffer-substring (point) (line-end-position))))
+ (let ((op (char-after (match-beginning 3)))
+ (m1 (match-string 1))
+ (m2 (match-string 2))
+ (m4 (match-string 4))
+ (m5 (match-string 5)))
+ (setq last1
+ (smerge--refine-highlight-change
+ beg1 m1 (if (eq op ?a) t m2)
+ ;; Try to use props-c only for changed chars,
+ ;; fallback to props-r for changed/removed chars,
+ ;; but if props-r is nil then fallback to props-c.
+ (or (and (eq op '?c) props-c) props-r props-c)))
+ (setq last2
+ (smerge--refine-highlight-change
+ beg2 m4 (if (eq op ?d) t m5)
+ ;; Same logic as for removed chars above.
+ (or (and (eq op '?c) props-c) props-a props-c))))
+ (overlay-put last1 'smerge--refine-other last2)
+ (overlay-put last2 'smerge--refine-other last1)
+ (forward-line 1) ;Skip hunk header.
+ (and (re-search-forward "^[0-9]" nil 'move) ;Skip hunk body.
+ (goto-char (match-beginning 0))))
+ ;; (cl-assert (or (null last1) (< (overlay-start last1) end1)))
+ ;; (cl-assert (or (null last2) (< (overlay-start last2) end2)))
+ (if smerge-refine-weight-hack
+ (progn
+ ;; (cl-assert (or (null last1) (<= (overlay-end last1) end1)))
+ ;; (cl-assert (or (null last2) (<= (overlay-end last2) end2)))
+ )
+ ;; smerge-refine-forward-function when calling in chopup may
+ ;; have stopped because it bumped into EOB whereas in
+ ;; smerge-refine-weight-hack it may go a bit further.
+ (if (and last1 (> (overlay-end last1) end1))
+ (move-overlay last1 (overlay-start last1) end1))
+ (if (and last2 (> (overlay-end last2) end2))
+ (move-overlay last2 (overlay-start last2) end2))
+ ))))))
+
;;;###autoload
(define-minor-mode futur-hacks-mode
"Various hacks to force Futur into various corners of Emacs.
@@ -140,13 +311,16 @@ Concretely this means:
This is used for:
- TAB completion in ELisp mode (where we need to
macroexpand the code).
- - Flymake byte-compilation in ELisp mode."
+ - Flymake byte-compilation in ELisp mode.
+- Run `smerge-refine-region' asynchronously."
:global t
(advice-remove 'elisp--safe-macroexpand-all #'futur--safe-macroexpand-all)
(advice-remove 'elisp-flymake-byte-compile #'futur--flymake-byte-compile)
+ (advice-remove 'smerge-refine-regions #'futur--smerge-refine-regions)
(when futur-hacks-mode
(advice-add 'elisp-flymake-byte-compile :override
#'futur--flymake-byte-compile)
+ (advice-add 'smerge-refine-regions :override
#'futur--smerge-refine-regions)
;; FIXME: This has no effect in Emacs<30 where this function doesn't exist
;; and its content is instead "hidden" inside `elisp--local-variables'.
(advice-add 'elisp--safe-macroexpand-all :override
diff --git a/futur-server.el b/futur-server.el
index 84db5d94be..2e2b484913 100644
--- a/futur-server.el
+++ b/futur-server.el
@@ -35,6 +35,8 @@
;; (trace-function 'futur--read-stdin)
;; (trace-function 'futur--print-stdout)
+;; (when (< emacs-major-version 31) (require 'comp-common nil t))
+
(defconst futur--elisp-impossible-string "\n# \"# "
"String that will necessarily cause `read' to signal an error.")
@@ -174,7 +176,10 @@ Does not pay attention to buffer-local values of
variables."
(setf (symbol-function sym) nil)
(setf (symbol-plist sym) nil)
(unless (keywordp sym) (makunbound sym)))
- (setf (symbol-function sym) (symbol-function ss))
+ ;; FIXME: Emacs<31 would try and compile trampolines needlessly
+ ;; (and unsuccessfully (because we're in a halfway state).
+ (unless (eq (symbol-function sym) (symbol-function ss))
+ (setf (symbol-function sym) (symbol-function ss)))
(setf (symbol-plist sym) (symbol-plist ss))
;; FIXME: Do we need to do something special for var-aliases?
(ignore-error setting-constant
diff --git a/futur-tests.el b/futur-tests.el
index 13bc469aa6..336e300639 100644
--- a/futur-tests.el
+++ b/futur-tests.el
@@ -175,10 +175,11 @@
:buffer buf)))
(list exitcode
(with-current-buffer buf
- (buffer-string)))))
- (res (futur-blocking-wait-to-get-result futur)))
- (should (equal res
- '(0 "00000000: 456d 6163 73
Emacs\n"))))))
+ (buffer-string))))))
+ (unwind-protect
+ (should (equal (futur-blocking-wait-to-get-result futur)
+ '(0 "00000000: 456d 6163 73
Emacs\n")))
+ (delete-file tmpfile)))))
(ert-deftest futur-process-bounded ()
(let* ((futures ())
@@ -202,11 +203,11 @@
(should (process-get proc 'futur--ready))
(should (null (process-get proc 'futur--destination)))))
-(ert-deftest futur-elisp-funcall ()
- (let ((fut (futur--elisp-funcall #'+ 5 7)))
+(defun futur--tests-elisp-funcall (elisp-funcall)
+ (let ((fut (funcall elisp-funcall #'+ 5 7)))
(should (equal 12 (futur-blocking-wait-to-get-result fut))))
- (let ((fut (futur--elisp-funcall #'car 7)))
+ (let ((fut (funcall elisp-funcall #'car 7)))
(should (equal (condition-case err1
(futur-blocking-wait-to-get-result fut)
(error err1))
@@ -214,7 +215,7 @@
(car 7)
(error err2)))))
- (let ((fut (futur--elisp-funcall #'documentation 'car)))
+ (let ((fut (funcall elisp-funcall #'documentation 'car)))
(should (equal (futur-blocking-wait-to-get-result fut)
(documentation 'car))))
@@ -222,65 +223,34 @@
(dotimes (i 1024)
(push i chars))
(apply #'string (nreverse chars))))
- (fut (futur--elisp-funcall #'identity str)))
+ (fut (funcall elisp-funcall #'identity str)))
(should (equal (futur-blocking-wait-to-get-result fut)
str)))
(let* ((f (lambda (context)
(futur-reset-context
'futur-test-mini context)
- (symbol-function 'diff-mode)))
+ (let ((fun (symbol-function 'diff-mode)))
+ ;; Beware: can't return a subr because it's not print-readable.
+ (if (subrp fun) 'subr fun))))
(fut
(futur-let*
- ((da1 <- (futur--elisp-funcall f ()))
- (da2 <- (futur--elisp-funcall f '(diff-mode)))
- (da3 <- (futur--elisp-funcall f ())))
+ ((da1 <- (funcall elisp-funcall f ()))
+ (da2 <- (funcall elisp-funcall f '(diff-mode)))
+ (da3 <- (funcall elisp-funcall f ())))
(list da1 da2 da3)))
(vals (futur-blocking-wait-to-get-result fut)))
(should (autoloadp (nth 0 vals)))
- (should (functionp (nth 1 vals)))
+ (should (or (functionp (nth 1 vals)) (eq 'subr (nth 1 vals))))
(should-not (equal (nth 0 vals) (nth 1 vals)))
(should (equal (nth 0 vals) (nth 2 vals)))))
-(ert-deftest futur-sandbox-funcall ()
- (let ((fut (futur--sandbox-funcall #'+ 5 7)))
- (should (equal 12 (futur-blocking-wait-to-get-result fut))))
-
- (let ((fut (futur--sandbox-funcall #'car 7)))
- (should (equal (condition-case err1
- (futur-blocking-wait-to-get-result fut)
- (error err1))
- (condition-case err2
- (car 7)
- (error err2)))))
+(ert-deftest futur-elisp-funcall ()
+ (futur--tests-elisp-funcall #'futur--elisp-funcall))
- (let ((fut (futur--sandbox-funcall #'documentation 'car)))
- (should (equal (futur-blocking-wait-to-get-result fut)
- (documentation 'car))))
- (let* ((str (let ((chars ()))
- (dotimes (i 1024)
- (push i chars))
- (apply #'string (nreverse chars))))
- (fut (futur--sandbox-funcall #'identity str)))
- (should (equal (futur-blocking-wait-to-get-result fut)
- str)))
-
- (let* ((f (lambda (context)
- (futur-reset-context
- 'futur-test-mini context)
- (symbol-function 'diff-mode)))
- (fut
- (futur-let*
- ((da1 <- (futur--sandbox-funcall f ()))
- (da2 <- (futur--sandbox-funcall f '(diff-mode)))
- (da3 <- (futur--sandbox-funcall f ())))
- (list da1 da2 da3)))
- (vals (futur-blocking-wait-to-get-result fut)))
- (should (autoloadp (nth 0 vals)))
- (should (functionp (nth 1 vals)))
- (should-not (equal (nth 0 vals) (nth 1 vals)))
- (should (equal (nth 0 vals) (nth 2 vals)))))
+(ert-deftest futur-sandbox-funcall ()
+ (futur--tests-elisp-funcall #'futur--sandbox-funcall))
(provide 'futur-tests)
;;; futur-tests.el ends here
diff --git a/futur.el b/futur.el
index c8ee49fd16..116c64e774 100644
--- a/futur.el
+++ b/futur.el
@@ -611,7 +611,7 @@ Returns a future that returns the same value as FORM.
Execution of FORMS is guarantee to occur after completion of FORM,
but it is not guaranteed to occur before completion of the returned future."
(declare (indent 1) (debug t))
- `(futur--unwind-protect ,form (lambda () ,@forms)))
+ `(futur--unwind-protect (futur-funcall (lambda () ,form)) (lambda ()
,@forms)))
;;;; Futur blockers
;; Futur blockers are the objects over which a futur can be waiting, like
