branch: externals/futur
commit 4ac3b6cc7e0de25f40b24185909d7b7b7a6d29f8
Author: Stefan Monnier <[email protected]>
Commit: Stefan Monnier <[email protected]>
futur.el, futur-tests.el: New files
---
futur-tests.el | 131 ++++++++++++
futur.el | 662 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 793 insertions(+)
diff --git a/futur-tests.el b/futur-tests.el
new file mode 100644
index 0000000000..735e23fdea
--- /dev/null
+++ b/futur-tests.el
@@ -0,0 +1,131 @@
+;;; futur-tests.el --- Tests for the Futur library -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2024 Stefan Monnier
+
+;; Author: Stefan Monnier <[email protected]>
+;; Keywords:
+
+;; 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 3 of the License, 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 this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;
+
+;;; Code:
+
+(require 'futur)
+
+(ert-deftest futur--resignal ()
+ (let ((err1 (list 'error "hello")))
+ (should (eq err1 (condition-case err2
+ (progn (futur--resignal err1) nil)
+ (error err2))))))
+
+(ert-deftest futur-simple ()
+ (should (equal (futur-blocking-wait-to-get-result (futur-done 5)) 5))
+
+ (let ((p (futur-error '(scan-error "Oops"))))
+ (should-error (futur-blocking-wait-to-get-result p) :type 'scan-error))
+
+ (should (equal
+ (futur-blocking-wait-to-get-result
+ (futur-let* ((x1 5)
+ (x2 <- (futur-done 7)))
+ (+ x1 x2)))
+ 12))
+
+ (let ((p (futur-let* ((x1 5)
+ (x2 <- (futur-error '(scan-error "Oops"))))
+ (list (+ x1 x2) (error "Wow!")))))
+ (should-error (futur-blocking-wait-to-get-result p) :type 'scan-error)))
+
+(ert-deftest futur-timeout ()
+ (let* ((x '())
+ (_timer1 (run-with-timer 0.1 nil (lambda () (push 'timer1 x))))
+ (_timer2 (run-with-timer 0.3 nil (lambda () (push 'timer2 x))))
+ (futur (futur-let* ((_ <- (futur-timeout 0.2))
+ (x1 x)
+ (_ <- (futur-timeout 0.2))
+ (x2 x))
+ (list x1 x2)))
+ (res (futur-blocking-wait-to-get-result futur)))
+ (should (equal res '((timer1) (timer2 timer1))))))
+
+(ert-deftest futur-list ()
+ (let* ((x '())
+ (_timer1 (run-with-timer 0.1 nil (lambda () (push 'timer1 x))))
+ (_timer2 (run-with-timer 0.6 nil (lambda () (push 'timer2 x))))
+ (futur (futur-list
+ (futur-let* ((_ <- (futur-timeout 0.4))) (cons 'a x))
+ (futur-let* ((_ <- (futur-timeout 0.3))) (cons 'b x))))
+ (res (futur-blocking-wait-to-get-result futur)))
+ (should (equal res '((a timer1) (b timer1))))))
+
+(ert-deftest futur-abort ()
+ (let* ((x '())
+ (start (float-time))
+ (timescale 0.2)
+ (_fut1 (futur-let* ((_ <- (futur-timeout (* timescale 1))))
+ (push 'timer1 x)))
+ (fut6 (futur-let* ((_ <- (futur-timeout (* timescale 6))))
+ (push 'timer6 x)))
+ (fut2 (futur-timeout (* timescale 2)))
+ (fut4 (futur-timeout (* timescale 4)))
+ (fut22 nil)
+ (futA (futur-list
+ (futur-let*
+ ((_ <- (futur-list fut2 (futur-timeout (* timescale 2))))
+ (_ (setq fut22 (futur-timeout (* timescale 2))))
+ (_ <- (futur-list fut4 fut22)))
+ (cons 'a x))
+ (futur-let* ((_ <- (futur-timeout (* timescale 3))))
+ (signal 'error (cons "" x)))))
+ (futB (futur-list fut4)))
+ (should (equal x ()))
+ (should (equal (condition-case err
+ (progn (futur-blocking-wait-to-get-result futA) t)
+ (error err))
+ '(error "" timer1)))
+ (should (equal x '(timer1)))
+ (should (< (- (float-time) start) (* timescale 4)))
+ (should (pcase fut6 ((futur-waiting _) t)))
+ (should (pcase fut2 ((futur-done 'nil) t)))
+ (should (pcase fut22 ((futur-error '(futur-aborted)) t)))
+ (should (pcase fut4 ((futur-waiting _) t) ((futur-done 'nil) t)))
+ (should (pcase futB ((futur-waiting _) t)))
+ (should (equal '(nil) (futur-blocking-wait-to-get-result futB)))
+ (should (equal x '(timer1)))))
+
+(ert-deftest futur-process ()
+ (with-temp-buffer
+ (let* ((tmpfile (make-temp-file "futur"))
+ (buf (current-buffer))
+ (_ (write-region "Emacs" nil tmpfile nil 'silent))
+ (futur
+ (futur-let* ((exitcode
+ <- (futur-process-make
+ :name "futur-hexl"
+ :command (list (expand-file-name
+ "hexl" exec-directory)
+ tmpfile)
+ :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"))))))
+
+(provide 'futur-tests)
+;;; futur-tests.el ends here
diff --git a/futur.el b/futur.el
new file mode 100644
index 0000000000..98ec8b9f0d
--- /dev/null
+++ b/futur.el
@@ -0,0 +1,662 @@
+;;; futur.el --- Future/promise-based async library -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2022 Stefan Monnier
+
+;; Author: Stefan Monnier <[email protected]>
+;; Keywords:
+
+;; 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 3 of the License, 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 this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; A library to try and make async programming a bit easier.
+;; This is inspired from Javscript's async/await, Haskell's monads,
+;; and ConcurrentML's events.
+
+;; You can create trivial futures with `futur-done'.
+;; You can create a "process future" with `futur-process-make'.
+;; And the main way to use futures is to compose them with `futur-let*',
+;; which can be used as follows:
+
+;; (futur-let*
+;; ((cmd (build-arg-list))
+;; (exitcode <- (futur-process-make :command cmd :buffer t))
+;; (out (buffer-string)) ;; Get the process's output.
+;; (cmd2 (build-second-arg-list exitcode out))
+;; (otherexit <- (futur-process-make :command cmd :buffer t)))
+;; (buffer-string))
+
+;; This example builds a future which runs two commands in sequence.
+;; For those rare cases where you really do want to block everything
+;; else and wait for a future to complete, you can
+;; use`futur-blocking-wait-to-get-result'.
+
+;; New kinds of futures can be constructed from:
+;; - `futur-waiting' to create the actual future.
+;; - `futur-deliver-value' to deliver the value to the future created earlier
+;; with `futur-waiting'.
+
+;;; Code:
+
+;; TODO:
+;; - Handle exceptions.
+
+(require 'cl-lib)
+
+(defvar futur--pending () "List of pending operations.")
+(defvar futur--pending-r ()
+ "List of additional pending operations in reverse-order.")
+
+(defconst futur--pending-mutex (make-mutex "futur-pending"))
+(defconst futur--pending-condition
+ (make-condition-variable futur--pending-mutex))
+
+(defvar futur--in-background nil)
+
+(defun futur--background ()
+ (let ((futur--in-background t))
+ (while t
+ (let ((pending
+ (with-mutex futur--pending-mutex
+ (while (and (null futur--pending)
+ (or (null futur--pending-r)
+ (progn
+ (setq futur--pending
+ (nreverse futur--pending-r))
+ (setq futur--pending-r nil)
+ nil)))
+ (condition-wait futur--pending-condition))
+ (pop futur--pending))))
+ (with-demoted-errors "future--background: %S"
+ (apply pending))))))
+
+(defconst futur--background
+ (make-thread #'futur--background "futur--background" 'silently))
+
+(defun futur--funcall (&rest args)
+ "Call ARGS like `funcall' but outside of the current dynamic scope.
+The code is conceptually run in another thread and while we try to run as
+soon as possible, and fairly, we do not guarantee the specific
+time or order of execution."
+ (with-mutex futur--pending-mutex
+ (push args futur--pending-r)
+ ;; FIXME: Maybe we should have combination
+ ;; `mutex-unlock+condition-notify', i.e. a variant of
+ ;; `condition-notify' which doesn't regrab the lock?
+ (condition-notify futur--pending-condition)))
+
+(defvar futur--idle-loop-bug80286
+ ;; "Idle loop" thread to try and make sure we run timers, filters, etc...
+ ;; Seems to give me assertion errors:
+ ;;
+ ;; process.c:5174: Emacs fatal error: assertion failed: XTHREAD
(ps->thread) == current_thread
+ ;; [Switching to Thread 0x7fffe186d6c0 (LWP 3046715)]
+ ;;
+ ;; Thread 8 "futur-idle-loop" hit Breakpoint 1, terminate_due_to_signal (
+ ;; sig=sig@entry=6, backtrace_limit=backtrace_limit@entry=2147483647)
+ ;; at emacs.c:445
+ ;;
+ ;;(when (fboundp 'make-thread)
+ ;; (make-thread
+ ;; (lambda ()
+ ;; (while t (accept-process-output nil (* 60 60 24))))
+ ;; "futur-idle-loop"))
+ nil)
+
+;;;; The `futur' data structure
+
+(cl-defstruct (futur
+ (:conc-name futur--)
+ (:noinline t)
+ (:predicate futur--p)
+ (:constructor nil)
+ (:constructor futur--done (value &aux (clients 't))
+ "Return a new `futur' that just returns VALUE.")
+ (:constructor futur--error (value &aux (clients 'error))
+ "Return a new `futur' that signals error VALUE")
+ (:constructor futur--waiting (&optional blocker clients
+ &aux (value blocker))
+ "Return a new `futur' that's waiting for BLOCKER."))
+ "A promise/future.
+A futur has 3 possible states:
+- (futur-done VAL): in that state, `clients' is `t', and `value' holds VAL.
+- (futur-error ERR): in that state, `clients' is `error', and `value' holds
ERR.
+- (futur-waiting BLOCKER CLIENTS): in that state, `clients' is a list
+ of \"callbacks\" waiting for the value or the error, and `value' holds
+ the BLOCKER that will deliver the value (can be another future,
+ a process, a thread, a list (of futures), or possibly other objects
+ with a `futur-blocker-wait' method)."
+ (clients nil)
+ (value nil))
+
+(pcase-defmacro futur-done (result)
+ `(and (pred futur--p)
+ (app futur--clients 't)
+ (app futur--value ,result)))
+
+(pcase-defmacro futur-error (error-object)
+ `(and (pred futur--p)
+ (app futur--clients 'error)
+ (app futur--value ,error-object)))
+
+(pcase-defmacro futur-waiting (&optional blocker clients)
+ `(and (pred futur--p)
+ (app futur--clients (and (pred listp) ,(or clients '_)))
+ (app futur--value ,(or blocker '_))))
+
+(defun futur--waiting-p (futur)
+ (pcase futur ((or (futur-waiting)
+ ;; Tell Pcase to presume FUTUR *is* a futur.
+ (and (pred (not futur--p)) pcase--dontcare))
+ t)))
+
+(define-inline futur--blocker (futur)
+ "Pseudo-slot for a waiting FUTUR."
+ (inline-letevals (futur)
+ (inline-quote (progn (cl-assert (futur--waiting-p ,futur))
+ (futur--value ,futur)))))
+
+(defun futur--deliver (futur err val)
+ (pcase-exhaustive futur
+ ((futur-waiting _ clients)
+ (setf (futur--clients futur) (if err 'error t))
+ (setf (futur--value futur) (or err val))
+ ;; CLIENTS is usually in reverse order since we always `push' to them.
+ (dolist (client (nreverse clients))
+ ;; Don't run the clients directly from here, so we don't nest,
+ ;; and also because we may be in an "interrupt" context where
+ ;; operations like blocking could be dangerous.
+ (futur--funcall client err val)))
+ ((pred futur--p)
+ (error "Delivering a second time: %S %S %S" futur err val))))
+
+(defun futur-deliver-value (futur val)
+ "Announce completion of FUTUR with result VAL."
+ (futur--deliver futur nil val))
+
+(defun futur-deliver-failure (futur error)
+ "Announce that computation of FUTUR encountered an ERROR."
+ (futur--deliver futur error nil))
+
+(defun futur-done (val)
+ "Build a trivial `futur' which returns VAL."
+ (futur--done val))
+
+(defun futur-error (error-object)
+ "Build a trivial `futur' which just signals ERROR-OBJECT."
+ (futur--error error-object))
+
+(defun futur-new (builder)
+ "Build a future.
+BUILDER is a function that will be called with one argument
+\(the new `futur' object, not yet fully initialized) and it should
+return the object on which the future is waiting.
+The code creating this future needs to call `futur-deliver-value'
+when the object has done the needed work.
+The object can be any object for which there is a `futur-blocker-wait' method."
+ (let* ((f (futur--waiting))
+ (x (funcall builder f)))
+ (cl-assert (null (futur--blocker f)))
+ (setf (futur--blocker f) x)
+ f))
+
+(defun futur-abort (futur)
+ "Interrupt execution of FUTUR, marking it as having failed.
+The error is `futur-aborted'. Does nothing if FUTUR was already complete."
+ (pcase futur
+ ((futur-waiting blocker)
+ (let ((error (list 'futur-aborted)))
+ (futur-blocker-abort blocker error)
+ (futur-deliver-failure futur error)))
+ (_ nil))) ;; No point in throwing away the result we already got.
+
+;;;; Composing futures
+
+(defun futur-register-callback (futur fun)
+ "Call FUN when FUTUR completes.
+Calls it with two arguments (ERR VAL), where only one of the two is non-nil,
+and throws away the return value. If FUTUR fails ERR is the error object,
+otherwise ERR is nil and VAL is the result value.
+When FUN is called, FUTUR is already marked as completed.
+If FUTUR already completed, FUN is called immediately."
+ (pcase futur
+ ((futur-waiting _ clients)
+ (setf (futur--clients futur) (cons fun clients)))
+ ((futur-error err) (funcall fun err nil))
+ ((futur-done val) (funcall fun nil val)))
+ nil)
+
+(defun futur-ize (val)
+ "Make sure VAL is a `futur'. If not, make it a trivial one that returns
VAL."
+ (if (futur--p val) val (futur--done val)))
+
+(defun futur-bind (futur fun &optional error-fun)
+ "Build a new future by composition.
+That future calls FUN with the return value of FUTUR and returns
+the same value as the future returned by FUN.
+If ERROR-FUN is non-nil, it should be a function that will be called instead of
+FUN when FUTUR fails. It is called with a single argument (the error object).
+By default any error in FUTUR is propagated to the returned future."
+ ;; This should behave like:
+ ;;
+ ;; (let ((new (futur--waiting futur)))
+ ;; (futur-register-callback futur
+ ;; (lambda (err val)
+ ;; (if err (futur-deliver-failure new err)
+ ;; (futur--run-continuation new fun (list val)))))
+ ;; new)
+ ;;
+ ;; But we try to skip the `new' futur if `futur' is already completed.
+ (pcase-exhaustive futur
+ ((futur-waiting _ clients)
+ (let ((new (futur--waiting futur)))
+ (setf (futur--clients futur)
+ (cons
+ (lambda (err val)
+ (if err (futur-deliver-failure new err)
+ (futur--run-continuation new fun (list val))))
+ clients))
+ new))
+ ((and (futur-error _) (guard (null error-fun))) futur)
+ ((or (futur-done value) (futur-error err1))
+ (condition-case-unless-debug err2
+ (let ((res (if err1 (funcall error-fun err1) (funcall fun value))))
+ (futur-ize res))
+ (t (futur-error err2))))))
+
+(defun futur--run-continuation (futur fun args)
+ ;; The thing FUTUR was waiting for is completed, maybe we'll soon be waiting
+ ;; for another future, but for now, we're waiting for some piece of ELisp
+ ;; (namely FUN) to terminate.
+ (setf (futur--blocker futur) 'elisp)
+ (condition-case-unless-debug err
+ (let ((res (apply fun args)))
+ (if (not (futur--p res))
+ (futur-deliver-value futur res)
+ (setf (futur--blocker futur) res)
+ (futur-register-callback res
+ (lambda (err val)
+ (if err (futur-deliver-failure futur err)
+ (futur-deliver-value futur val))))))
+ (t (futur-deliver-failure futur err))))
+
+(defun futur--resignal (error-object)
+ ;; Undocumented feature of `signal', this re-signals an error using the exact
+ ;; same error object:
+ ;; (should (eq e1 (condition-case e2 (signal e1 nil) (error e2))))
+ (signal error-object nil))
+
+(defun futur-blocking-wait-to-get-result (futur &optional error-fun)
+ "Wait for FUTUR to deliver and then return its value.
+Ideally, this should never be used, hence the long name to discourage
+abuse. Instead, you should use `futur-bind' or `futur-let*' to execute
+what you need when FUTUR completes.
+If FUTUR fails, calls ERROR-FUN with the error object and returns
+its result, or (re)signals the error if ERROR-FUN is nil."
+ ;; Waiting for a task to finish has always been a PITA in ELisp,
+ ;; because `sit-for/accept-process-output/sleep-for' have proved brittle
+ ;; with lots of weird corner cases. `futur-blocker-wait' does its best,
+ ;; thanks to years of bug fixing, but it's still messy and brittle.
+ ;; See the VCS history of `url-retrieve-synchronously' for another example.
+ ;; The use of `condition-notify' should side-step this problem, except
+ ;; that bug#80286 means that `condition-wait' can lock up your
+ ;; Emacs session hard.
+ ;; FIXME: Even `futur--idle-loop-bug80286' doesn't seem sufficient.
+ (when futur--in-background
+ (error "Blocking/waiting within an asynchronous context is not supported"))
+ (if t ;; (null futur--idle-loop-bug80286)
+ (futur-blocker-wait futur)
+ (let* ((mutex (make-mutex "futur-wait"))
+ (condition (make-condition-variable mutex)))
+ (with-mutex mutex
+ (futur-register-callback futur (lambda (_err _val)
+ (with-mutex mutex
+ (condition-notify condition))))
+ (condition-wait condition))))
+ (pcase-exhaustive futur
+ ((futur-error err) (funcall (or error-fun #'futur--resignal) err))
+ ((futur-done val) val)))
+
+(defmacro futur-let* (bindings &rest body)
+ "Sequence asynchronous operations via futures.
+BINDINGS can contain the usual (VAR EXP) bindings of `let*' but also
+\(VAR <- EXP) bindings where EXP should return a future, in which case
+the rest of the code is executed only once the future terminates,
+binding the result in VAR. BODY is executed at the very end and should
+return a future.
+BODY can start with `:error-fun ERROR-FUN' in which case errors in
+the futures in BINDINGS will cause execution of ERROR-FUN instead of BODY.
+ERROR-FUN is called with a single argument, the error object."
+ (declare (indent 1) (debug ((&rest (sexp . [&or ("<-" form) (form)])) body)))
+ (cl-assert lexical-binding)
+ (let ((error-fun (when (eq :error-fun (car body))
+ (prog1 (cadr body)
+ (setq body (cddr body))))))
+ (if (not (symbolp error-fun))
+ (macroexp-let2 nil error-fun error-fun
+ `(futur-let* ,bindings :error-fun ,error-fun ,@body))
+ (named-let loop ((bindings bindings))
+ (pcase-exhaustive bindings
+ ('() (macroexp-progn body))
+ (`((,var ,exp) . ,bindings)
+ ;; FIXME: Catch errors in EXP to run `error-fun'?
+ `(pcase-let ((,var ,exp)) ,(loop bindings)))
+ (`((,var <- ,exp) . ,bindings)
+ `(futur-bind ,exp
+ (lambda (,var) ,(loop bindings))
+ ,error-fun)))))))
+
+(oclosure-define futur--aux
+ "An auxiliary function used internally. Does not need the future's
completion.")
+
+(defun futur--multi-clients-p (clients)
+ (let ((count 0))
+ (while (and clients (< count 2))
+ (let ((client (pop clients)))
+ (if (cl-typep client 'futur--aux) nil
+ (cl-incf count))))
+ (>= count 2)))
+
+(defun futur--unwind-protect (futur fun)
+ "Make sure FUN is called, with no arguments, once FUTUR completes.
+Calls it both when FUTUR succeeds and when it fails.
+Unlike what happens with `unwind-protect', there is no guarantee of
+exactly when FUN is called, other than not before FUTUR completes."
+ ;; FIXME: Not sure if this implementation is making enough efforts to make
+ ;; sure not to forget to run FUN. Maybe we should register FUTUR+FUN
+ ;; on some global list somewhere that we can occasionally scan, in case
+ ;; something happened that prevented running FUN?
+ (let ((futur (futur-ize futur)))
+ ;; Use `futur--aux' to let `futur--multi-clients-p' know not to count
+ ;; this function as a "real" client.
+ (futur-register-callback futur (oclosure-lambda (futur--aux) (_ _)
+ (funcall fun)))
+ futur))
+
+(defmacro futur-unwind-protect (form &rest forms)
+ "Run FORM, and when that completes, run FORMS.
+FORM is supposed to return a `futur'.
+When that future completes, run FORMS.
+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 blockers
+;; Futur blockers are the objects over which a futur can be waiting, like
+;; a process, a timer, another futur, ...
+;; These need to implement `futur-blocker-wait' and `futur-blocker-abort'.
+
+(cl-defgeneric futur-blocker-wait (_object)
+ "Wait for OBJECT to complete.
+OBJECT is an object some FUTUR is waiting.
+Return non-nil if we successfully waited until the completion of BLOCKER."
+ nil)
+
+(cl-defmethod futur-blocker-wait ((futur futur))
+ (if (not (futur--waiting-p futur))
+ nil ;; FUTUR already completed.
+ (let ((i 0))
+ (while
+ (pcase futur
+ ((futur-waiting blocker)
+ (if (futur-blocker-wait blocker)
+ (setq i 0)
+ (let ((delay (* 0.01 (expt 1.1 i))))
+ (if (> delay 1.0)
+ (sit-for 0) ;; Just redisplay every 1s, just in case.
+ (setq i (1+ i)))
+ (accept-process-output nil delay)))
+ ;; Always retry since even if `futur-blocker-wait' succeeded,
+ ;; the futur might not have completed yet (and it may have
+ ;; a new blocker).
+ t)))
+ t)))
+
+(define-error 'futur-aborted "Future aborted")
+
+(cl-defgeneric futur-blocker-abort (futur error)
+ "Abort processing of FUTUR and all of its clients.
+If it had not been computed yet, then make it fail with ERROR.")
+
+(cl-defmethod futur-blocker-abort ((futur futur) error)
+ (let ((blocker (futur--blocker futur)))
+ (if (pcase blocker ((futur-waiting _ (pred futur--multi-clients-p)) t))
+ ;; If there are more than 1 clients, presumably someone else is
+ ;; still interested in FUTURs result, so we shouldn't abort it.
+ ;; FIXME: We should "unbind" ourselves from it, tho, otherwise
+ ;; when it completes it will deliver its result to us.
+ nil
+ ;; If CLIENTS has only one element, it's presumably ourselves,
+ ;; so we should definitely abort that futur.
+ (futur-blocker-abort blocker error))
+ ;; Regardless if we aborted the blocker, abort this future,
+ ;; but don't "deliver" since our caller should take care of it.
+ (setf (futur--clients futur) 'error)
+ (setf (futur--value futur) error)))
+
+(cl-defmethod futur-blocker-abort ((_ (eql 'elisp)) _error)
+ ;; FIXME: No idea how to do that!
+ nil)
+
+;;;; Postpone
+
+(defun futur-timeout (time &optional idle)
+ "Return nil in TIME seconds.
+If IDLE is non-nil, then wait for that amount of idle time."
+ (futur-new
+ (lambda (futur)
+ (cons 'timer ;; FIXME: Make timers proper structs instead!
+ (funcall (if idle #'run-with-idle-timer #'run-with-timer)
+ time nil
+ (lambda (futur) (futur-deliver-value futur nil))
+ futur)))))
+
+(cl-defmethod futur-blocker-wait ((timer (head timer)))
+ (setq timer (cdr timer))
+ ;; No support for repeated timers (yet?).
+ (cl-assert (not (timer--repeat-delay timer)))
+ (if (timer--triggered timer)
+ nil ;; Already completed.
+ (while (not (timer--triggered timer))
+ (let* ((idle (timer--idle-delay timer))
+ (time (timer--time timer))
+ (delay (time-to-seconds
+ (if idle time (time-subtract time (current-time))))))
+ (accept-process-output nil (min 1.0 (max 0.01 delay)))
+ (if (> delay 1) (sit-for 0)))) ;; Redisplay every 1s, just in case.
+ t))
+
+(cl-defmethod futur-blocker-abort ((timer (head timer)) _error)
+ (cancel-timer (cdr timer)))
+
+;;;; Processes
+
+(defun futur--process-completed-p (proc)
+ (memq (process-status proc) '(exit signal closed failed)))
+
+(defun futur--process-sentinel (proc futur)
+ (when (futur--process-completed-p proc)
+ (futur-deliver-value futur (process-exit-status proc))))
+
+(defun futur-process-make (&rest args)
+ "Create a process and return a future that delivers its exit code.
+The ARGS are like those of `make-process' except that they can't include
+`:sentinel' because that is used internally."
+ (futur-new
+ (lambda (f) (apply #'make-process
+ :sentinel
+ (lambda (proc _state)
+ (futur--process-sentinel proc f))
+ args))))
+
+(defun futur-process-call--filter (proc string)
+ (let* ((file (process-get proc 'futur-destination)))
+ (write-region string nil file 'append 'silent)))
+
+(defun futur-process-call (program &optional infile destination _display
+ &rest args)
+ "Like `call-process' but runs concurrently as a `futur'.
+The DISPLAY argument is ignored: redisplay always happens."
+ (when (eq t (car-safe (cdr-safe destination)))
+ (setq destination (car destination)))
+ (pcase destination
+ (0 (error "A value of 0 is not supported for DESTINATION"))
+ ('t (setq destination (current-buffer)))
+ ((pred stringp) (setq destination (get-buffer-create destination)))
+ (`(:file ,(and file (pred stringp)))
+ (setq destination (expand-file-name file)))
+ (`(,_ . ,_) (error "Separate handling of stderr is not supported yet")))
+ (let* ((futur (futur-process-make
+ :name program
+ :command (cons program args)
+ :coding (if (stringp destination) '(binary . nil))
+ :connection-type 'pipe
+ :buffer (if (bufferp destination) destination)
+ :filter (if (bufferp destination) nil
+ #'futur-process-call--filter)))
+ (proc (pcase-exhaustive futur ((futur-waiting blocker) blocker))))
+ (when (stringp destination)
+ (write-region "" nil destination nil 'silent))
+ (pcase-exhaustive infile
+ ('nil (process-send-eof proc))
+ ((pred stringp) (futur-send-file proc infile)))
+ (process-put proc 'futur-destination destination)
+ futur))
+
+(defun futur-process-exit-status (proc)
+ "Create a future that returns the exit code of the process PROC."
+ (if (memq (process-status proc) '(exit signal closed failed))
+ (futur-done (process-exit-status proc))
+ (futur-new
+ (lambda (f)
+ ;; FIXME: If the process's sentinel signals an error, it won't run us
:-(
+ (add-function :after (process-sentinel proc)
+ (lambda (proc _state)
+ (futur--process-sentinel proc f)))
+ proc))))
+
+(cl-defmethod futur-blocker-wait ((proc process))
+ (if (futur--process-completed-p proc)
+ nil
+ (while (and
+ (not (futur--process-completed-p proc))
+ (accept-process-output proc 1.0))
+ (sit-for 0)) ;; Redisplay every 1s, just in case.
+ t))
+
+(cl-defmethod futur-blocker-abort ((proc process) _error)
+ (delete-process proc))
+
+(defun futur-process-send (proc string)
+ ;; FIXME: This is quite inefficient. Our C code should instead provide
+ ;; a non-blocking `(process-send-string PROC STRING CALLBACK)'.
+ (futur-new
+ (lambda (f) (make-thread
+ (lambda () (futur-deliver-value f (process-send-string proc
string)))
+ "futur-process-send" 'silently))))
+
+(cl-defmethod futur-blocker-wait ((th thread))
+ (if (not (thread-live-p th))
+ nil
+ (thread-join th)
+ t))
+
+(cl-defmethod futur-blocker-abort ((th thread) error)
+ ;; FIXME: This doesn't guarantee that the thread is aborted.
+ ;; FIXME: Let's hope that the undocumented feature of `signal' applies
+ ;; also to `thread-signal'.
+ (thread-signal th error nil))
+
+;;;; Multi futures: Futures that are waiting for several other futures.
+
+(defun futur-list (&rest futurs)
+ "Build a futur that returns the list of values of FUTURS.
+If one of FUTURS fails, fails the whole future and aborts those FUTURS
+that have not yet completed."
+ (if (null futurs)
+ (futur-done nil)
+ (let* ((new (futur--waiting futurs))
+ (count (length futurs))
+ (failed nil)
+ (args (make-list count :futur--waiting-for-result))
+ (i 0))
+ (dolist (futur futurs)
+ (futur-register-callback futur
+ (let ((cell (nthcdr i args)))
+ (lambda (err val)
+ (cl-assert (eq :futur--waiting-for-result (car cell)))
+ (cond
+ (failed nil)
+ (err
+ (setq failed t)
+ (futur-deliver-failure new err)
+ ;; Abort the remaining ones.
+ (let ((abort-error (list 'futur-aborted)))
+ (futur-blocker-abort futurs abort-error)))
+ (t
+ (setf (car cell) val)
+ (setq count (1- count))
+ (when (zerop count)
+ (pcase new
+ ;; We don't unbind ourselves from some FUTURs
+ ;; when aborting, so ignore their delivery here.
+ ((futur-error '(futur-aborted)) nil)
+ (_ (futur-deliver-value new args)))))))))
+ (setq i (1+ i)))
+ new)))
+
+(cl-defmethod futur-blocker-wait ((_blockers cons))
+ ;; FIXME: The loop below can misbehave when there's an early-exit
+ ;; because of an error: we may remain waiting for the first blocker
+ ;; while the second blocker has already signaled an error causing the
+ ;; whole future to be aborted. So we just "punt" and fallback on the
+ ;; "generic" (and thus less efficient) wait loop
+ ;;(let ((waited nil))
+ ;; (dolist (blocker blockers)
+ ;; (when (futur-blocker-wait blocker) (setq waited t)))
+ ;; waited)
+ nil)
+
+(cl-defmethod futur-blocker-abort ((futurs cons) error)
+ ;; Propagate the abort to the futurs we're still waiting for.
+ (dolist (futur futurs)
+ (pcase futur
+ ((futur-waiting _ clients)
+ (if (futur--multi-clients-p clients)
+ ;; If there are more than 1 clients, presumably someone else is
+ ;; still interested in FUTURs result, so we shouldn't abort it.
+ ;; FIXME: We should "unbind" ourselves from it, tho, otherwise
+ ;; when it completes it will deliver its result to us.
+ nil
+ ;; If CLIENTS has only one element, it's presumably ourselves,
+ ;; so we should definitely abort that futur.
+ (futur-blocker-abort futur error))))))
+
+;;;; Other helpers
+
+(defmacro futur-with-temp-buffer (&rest body)
+ (declare (indent 0) (debug t))
+ `(futur--with-temp-buffer (lambda () ,@body)))
+
+(defun futur--with-temp-buffer (body-fun)
+ (let ((buf (generate-new-buffer " *temp*" t)))
+ (futur--unwind-protect
+ (with-current-buffer buf (funcall body-fun))
+ (lambda () (and (buffer-live-p buf)
+ (kill-buffer buf))))))
+
+(provide 'futur)
+;;; futur.el ends here
