nix-archive-1(type directoryentry(namesharenode(type directoryentry(name common-lispnode(type directoryentry(namesourcenode(type directoryentry(namecl-async-futurenode(type directoryentry(name README.mdnode(typeregularcontentsTcl-async-future =============== This is a standalone library for futures in Common Lisp that was originally part of [cl-async](https://github.com/orthecreedence/cl-async). [Documentation](http://orthecreedence.github.com/cl-async/future) ----------------------------------------------------------------- Documentation for cl-async-future lives on the [cl-async website](http://orthecreedence.github.com/cl-async/future). Tests ----- The test suite can be run by doing the following: ```common-lisp (ql:quickload :cl-async-future-test) (cl-async-future-test:run-tests) ``` License ------- MIT. ))entry(namecl-async-future-test.asdnode(typeregularcontentss(asdf:defsystem cl-async-future-test :author "Andrew Danger Lyon " :license "MIT" :version "0.2" :description "TESTS FOR cl-async-future." :depends-on (#:cl-async #:cl-async-future #:eos) :components ((:module test :serial t :components ((:file "util") (:file "future") (:file "run"))))) ))entry(namecl-async-future.asdnode(typeregularcontentsF(asdf:defsystem cl-async-future :author "Andrew Danger Lyon " :license "MIT" :version "0.4.4.1" :description "A futures implementation for Common Lisp. Plugs in nicely to cl-async." :depends-on (#:blackbird) :components ((:file "package") (:file "future" :depends-on ("package")))) ))entry(name future.lispnode(typeregularcontentsč ;;; Define a set of backwards-compatible functions and methods for the future-* ;;; -> promise-* renaming that was previously in cl-async-future. (in-package :cl-async-future) (eval-when (:load-toplevel :compile-toplevel) (defun str-replace (string old new) "Replace a portion of a string with another." (let ((pos (search old string :test 'string=))) (if pos (str-replace (concatenate 'string (subseq string 0 pos) new (subseq string (+ pos (length old)))) old new) string)))) (defmacro with-forwarded (name (promisified) &body body) (let ((_str-name (gensym "str-name"))) `(let* ((,_str-name (string-downcase (string ,name))) (,promisified (intern (string-upcase (str-replace ,_str-name "future" "promise"))))) `(progn ,,@body ;; would rather these be explicit exports in package.lisp ;(export ',,name) )))) (defmacro forward-function (name) (with-forwarded name (promisified) `(setf (symbol-function ',name) (symbol-function ',promisified)))) (defmacro forward-macro (name) (with-forwarded name (promisified) `(setf (macro-function ',name) (macro-function ',promisified)))) ;; ----------------------------------------------------------------------------- ;; let the forwarding begin! ;; ----------------------------------------------------------------------------- (defclass future (promise) ((preserve-callbacks :accessor promise-preserve-callbacks :initarg :preserve-callbacks :initform nil :documentation "When nil (the default) detaches callbacks after running promise.") (reattach-callbacks :accessor promise-reattach-callbacks :initarg :reattach-callbacks :initform t :documentation "When a promise's callback returns another promise, bind all callbacks from this promise onto the returned one. Allows values to transparently be derived from many layers deep of promises, almost like a real call stack."))) (defun make-future (&key preserve-callbacks (reattach-callbacks t)) "Create a blank future." (make-instance 'future :preserve-callbacks preserve-callbacks :reattach-callbacks reattach-callbacks)) (forward-function future-finished-p) (forward-function future-values) (forward-function lookup-forwarded-future) (forward-function futurep) (forward-function reset-future) (forward-macro multiple-future-bind) (setf (macro-function 'wait-for) (macro-function 'wait)) ;; ----------------------------------------------------------------------------- ;; old error handling stuff ;; ----------------------------------------------------------------------------- (defmacro %handler-case (body &rest bindings) "Simple wrapper around handler-case that allows switching out the form to make macroexpansion a lot easier to deal with." `(handler-case ,body ,@bindings)) (defmacro wrap-event-handler (future-gen error-forms) "Used to wrap the future-generation forms of future syntax macros. This macro is not to be used directly, but instead by future-handler-case. It allows itself to be recursive, but any recursions will simply add their error forms for a top-level list and return the form they are given as the body. This allows a top-level form to add an error handler to a future, while gathering the lower-level forms' handler-case bindings into one big handler function (created with make-nexted-handler-cases). Note that since normally the wrap-event-handler forms expand outside in, we have to do some trickery with the error-handling functions to make sure the order of the handler-case forms (as far as what level of the tree we're on) are preserved." (let ((signal-error (gensym "signal-error")) (handler-fn (gensym "handler-fn")) (vals (gensym "vals"))) ;; hijack any child wrap-event-handler macros to just return their ;; future-gen form verbatim, but add their error handlers to the error ;; handling chain `(macrolet ((wrap-event-handler (future-gen error-forms) (let ((old-signal-error (gensym "old-signal-error"))) `(progn ;; "inject" the next-level down error handler in between the ;; error triggering function and the error handler one level ;; up. this preserves the handler-case tree (as opposed to ;; reversing it) ;; NOTE that signal-error is defined *below* in the body ;; of the macrolet form (let ((,old-signal-error ,',signal-error)) (setf ,',signal-error (lambda (ev) (%handler-case (funcall ,old-signal-error ev) ,@error-forms)))) ;; return the future-gen form verbatim ,future-gen)))) ;; define a function that signals the error, and a top-level error handler ;; which uses the error-forms passed to THIS macro instance. any instance ;; of `wrap-event-handler` that occurs in the `future-gen` form will inject ;; its error handler between handler-fn and signal-error. (let* ((,signal-error (lambda (ev) (error ev))) (,handler-fn (lambda (ev) (%handler-case (funcall ,signal-error ev) ,@error-forms))) ;; sub (wrap-event-handler ...) forms are expanded with ,future-gen ;; they add their handler-case forms into a lambda which is injected ;; into the error handling chain, (,vals (multiple-value-list ,future-gen))) (if (futurep (car ,vals)) (progn (attach-errback (car ,vals) ,handler-fn) (car ,vals)) (apply #'values ,vals)))))) (defmacro future-handler-case (body-form &rest error-forms &environment env) "Wrap all of our lovely attach macro up with an event handler. This is more or less restricted to the form it's run in. Note that we only have to wrap (attach) because *all other syntax macros* use attach. This greatly simplifies our code. Note that if we just wrap `attach` directly in a macrolet, it expands infinitely (probably no what we want). So we're doing some trickery here. We use the environment from the top-level macro to grab the original macro function and make it available from *within* the macrolet. This allows the macrolet to redefine the `attach` macro while also simultaneously expanding the previous definition of it. This allows wrapped calls of future-handler-case to add layers of error handling around any `attach` call that is within lexical grasp." (if (or (find :future-debug *features*) (find :future-debug *features*)) ;; we're debugging futures...disable all error handling (so errors bubble ;; up to main loop) body-form ;; wrap the top-level form in a handler-case to catch any errors we may ;; have before the futures are even generated. `(%handler-case ;; redefine our attach macro so that the future-gen forms are ;; wrapped (recursively, if called more than once) in the ;; `wrap-event-handler` macro. (macrolet ((attach (future-gen fn &environment ml-env) (let ((args (gensym "phc-wrap-args"))) ;; call the original attach macro (via our pass env). ;; this allows calling it without throwing macrolet ;; into an endless loop (funcall (macro-function 'attach ',env) `(attach (wrap-event-handler ,future-gen ,',error-forms) ;; create a wrapper function around the given ;; callback that applies our error handlers (lambda (&rest ,args) (%handler-case (apply ,fn ,args) ,@',error-forms))) ml-env)))) ,body-form) ,@error-forms))) ))entry(name package.lispnode(typeregularcontents(defpackage :cl-async-future (:use :cl :blackbird-base :blackbird-syntax :blackbird) (:nicknames :asf) (:import-from :blackbird-base #:finish #:lookup-forwarded-promise #:promise-values) (:export #:future #:future-finished-p #:make-future #:attach-errback #:lookup-forwarded-future #:signal-error #:futurep #:finish #:reset-future #:attach #:alet #:alet* #:aif #:multiple-future-bind #:wait-for #:adolist #:future-handler-case)) (in-package :cl-async-future) (loop for sym being the external-symbols of (find-package :blackbird) do (import sym) (export sym)) ))entry(nametestnode(type directoryentry(name future.lispnode(typeregularcontents©(in-package :cl-async-future-test) (in-suite cl-async-future-test) ;; TODO: finishing, forwarding, error handling, syntax macros, attach with value ;; vs future (immediate finish) (test make-future "Test that make-future returns a future, also test futurep" (is (futurep (make-future))) (is (futurep (make-future :preserve-callbacks t :reattach-callbacks nil))) (is (not (futurep 'hai))) (is (not (futurep "omg, WHERE did you get those shoes?!"))) (is (not (futurep nil)))) (test future-callbacks "Test that finishing a future fires its callbacks, also test multiple callbacks" (let ((future (make-future)) (res1 nil) (res2 nil)) (attach future (lambda (x) (setf res1 (+ 3 x)))) (attach future (lambda (x) (setf res2 (+ 7 x)))) (finish future 5) (is (= res1 8)) (is (= res2 12)))) (test future-errbacks "Test that errbacks are fired (also test multiple errbacks)" (let ((future (make-future)) (fired1 nil) (fired2 nil)) (attach-errback future (lambda (ev) (setf fired1 ev))) (attach-errback future (lambda (ev) (setf fired2 ev))) (signal-error future 'omg-lol-wtf) (is (eq fired1 'omg-lol-wtf)) (is (eq fired2 'omg-lol-wtf)))) (defun future-gen (&rest vals) (let ((future (make-future))) (as:delay (lambda () (apply #'finish (append (list future) vals))) :time .2 :event-cb (lambda (ev) (signal-error future ev))) future)) (test future-alet "Test that the alet macro functions correctly" (let ((time-start nil)) ; tests that alet bindings happen in parallel (multiple-value-bind (val-x val-y) (async-let ((val-x nil) (val-y nil)) (setf time-start (get-internal-real-time)) (alet ((x (future-gen 5)) (y (future-gen 2))) (setf val-x x val-y y))) (is (<= .19 (/ (- (get-internal-real-time) time-start) internal-time-units-per-second) .22)) (is (= val-x 5)) (is (= val-y 2))))) (test future-alet* "Test that the alet* macro functions correctly" (let ((time-start nil)) ; tests that alet bindings happen in sequence (multiple-value-bind (val-x val-y) (async-let ((val-x nil) (val-y nil)) (setf time-start (get-internal-real-time)) (alet* ((x (future-gen 5)) (y (future-gen (+ 2 x)))) (setf val-x x val-y y))) (let ((alet*-run-time (/ (- (get-internal-real-time) time-start) internal-time-units-per-second))) (is (<= .38 alet*-run-time .42)) (is (= val-x 5)) (is (= val-y 7)))))) (test future-multiple-future-bind "Test multiple-future-bind macro" (multiple-value-bind (name age) (async-let ((name-res nil) (age-res nil)) (multiple-future-bind (name age) (future-gen "andrew" 69) (setf name-res name age-res age))) (is (string= name "andrew")) (is (= age 69)))) (test future-wait-for "Test wait-for macro" (multiple-value-bind (res1 res2) (async-let ((res1 nil) (res2 nil)) (wait-for (future-gen nil) (setf res1 2)) (wait-for (future-gen nil) (setf res2 4))) (is (= res1 2)) (is (= res2 4)))) (define-condition test-error-lol (error) ()) (test future-handler-case "Test future error handling" (multiple-value-bind (err1 err2) (async-let ((err1 nil) (err2 nil)) (future-handler-case (future-handler-case (alet ((x (future-gen 'sym1))) (+ x 7)) (type-error (e) (setf err1 e))) (t (e) (declare (ignore e)) (setf err1 :failwhale))) (future-handler-case (future-handler-case (multiple-future-bind (name age) (future-gen "leonard" 69) (declare (ignore name age)) (error (make-instance 'test-error-lol))) (type-error (e) (setf err2 e))) (t (e) (setf err2 e)))) (is (subtypep (type-of err1) 'type-error)) (is (subtypep (type-of err2) 'test-error-lol)))) (test forwarding "Test future forwarding" (flet ((get-val () (alet ((x 4)) (alet ((y (+ x 4))) (+ x y))))) (alet ((res (get-val))) (is (= res 12))))) ;; ----------------------------------------------------------------------------- ;; test error propagation ;; ----------------------------------------------------------------------------- (define-condition future-error (type-error) ((msg :initarg :msg :reader future-errmsg :initform nil)) (:report (lambda (c s) (format s "Error event: ~a" (future-errmsg c))))) (defun fdelay (val) (let ((future (make-future))) (finish future (+ val 1)) future)) (defmacro defafun (name (future-bind) args &body body) `(defun ,name ,args (let ((,future-bind (make-future))) (future-handler-case (progn ,@body) (t (e) (signal-error ,future-bind e))) ,future-bind))) (defafun async2 (future) (a) (alet* ((z (fdelay a)) (b (+ z 1))) (error 'future-error :msg "\"5\" is no expected type NUMBER") (finish future (+ b 6)))) (defafun async1 (future) (a) (alet* ((x (fdelay a)) (y (async2 x))) (finish future y))) (test error-propagation "Test error propagation" (let ((error-triggered nil)) (future-handler-case (wait-for (async1 1) (setf error-triggered nil)) (t (e) (setf error-triggered t) (is (typep e 'type-error)))) (is (eq error-triggered t)))) ))entry(namerun.lispnode(typeregularcontentsX(in-package :cl-async-future-test) (defun run-tests () (run! 'cl-async-future-test)) ))entry(name util.lispnode(typeregularcontents“(defpackage :cl-async-future-test (:use :cl :eos :cl-async-base :cl-async-util :cl-async-future) (:export #:run-tests)) (in-package :cl-async-future-test) ;; TODO: test all functions in util package (defmacro async-let ((&rest bindings) &body body) "Wrap an async op inside of a let/start-event-loop block to mimick a blocking action. Bindings must be set from withing the block via setf." `(let ,bindings (as:start-event-loop (lambda () ,@body) :catch-app-errors t) (values ,@(loop for (binding . nil) in bindings collect binding)))) (defun concat (&rest args) "Shortens string concatenation because I'm lazy and really who the hell wants to type out (concatenate 'string ...) seriously, I mispell concatentate like 90% of the time I type it out." (apply #'concatenate (append '(string) args))) (defun id (val) "Returns val. Yes, yes. I know that the identity function exists, but seriously I'm not going to waste precious time out of my life typing identity when I can just type id. The idea is the same, and everybody KNOWS what I'm trying to express. Oh one more thing: the only reason I NEED identi...err, id is because Eos can't use its `is` macro around another macro. So I need a function to wrap it. Lame. BUT such is life." val) ;; define the test suite (def-suite cl-async-future-test :description "cl-async-future test suite") ))))))))entry(namesystemsnode(type directoryentry(namecl-async-future-test.asdnode(typesymlinktarget/gnu/store/008n0hvzdlqsxm2ddvr73b1zx6vpy56q-cl-async-future-0.4.4.1-1.ee36c22/share/common-lisp/source/cl-async-future/cl-async-future-test.asd))entry(namecl-async-future.asdnode(typesymlinktargetŠ/gnu/store/008n0hvzdlqsxm2ddvr73b1zx6vpy56q-cl-async-future-0.4.4.1-1.ee36c22/share/common-lisp/source/cl-async-future/cl-async-future.asd)))))))))