diff --git a/.ert-runner b/.ert-runner new file mode 100644 index 0000000..e35e9c9 --- /dev/null +++ b/.ert-runner @@ -0,0 +1 @@ +-L . diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..cc05f55 --- /dev/null +++ b/.gitignore @@ -0,0 +1,11 @@ +# Compiled and temporary files +*.elc +*~ + +# Cask +/.cask +dist + +# Ecukes +/features/project/.cask +/features/project/test/*.el diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..5744ea3 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,17 @@ +language: generic +sudo: false +before_install: + - curl -fsSkL https://gist.github.com/rejeep/ebcd57c3af83b049833b/raw > x.sh && source ./x.sh + - evm install $EVM_EMACS --use --skip + - cask +env: + - EVM_EMACS=emacs-24.3-travis + - EVM_EMACS=emacs-24.4-travis + - EVM_EMACS=emacs-24.5-travis + +script: + - emacs --version + - make travis-ci +after_script: + - cat /tmp/undercover-report.json + - curl -v -include --form json_file=@/tmp/undercover-report.json https://coveralls.io/api/v1/jobs \ No newline at end of file diff --git a/Cask b/Cask new file mode 100644 index 0000000..3671c39 --- /dev/null +++ b/Cask @@ -0,0 +1,12 @@ +(source gnu) +(source melpa) + +(package-file "deferred.el") + +(development + (depends-on "f") + (depends-on "ecukes") + (depends-on "ert-runner") + (depends-on "el-mock") + (depends-on "cask-package-toolset") + (depends-on "undercover")) diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..6696aca --- /dev/null +++ b/Makefile @@ -0,0 +1,42 @@ +EMACS ?= emacs +CASK ?= cask + +CURL=curl --silent -L +ERT_URL=http://git.savannah.gnu.org/cgit/emacs.git/plain/lisp/emacs-lisp/ert.el?h=emacs-24 +ERT=ert +CL_URL=https://raw.githubusercontent.com/emacsmirror/cl-lib/master/cl-lib.el +CL=cl-lib + +.PHONY: test test-deferred test-concurrent compile clean print-deps travis-ci + +test: test-deferred test-deferred-compiled test-concurrent +# test-concurrent-compiled + +test-deferred: + $(CASK) exec ert-runner test/deferred-test.el + +test-deferred-compiled: deferred.elc + $(CASK) exec ert-runner test/deferred-test.el -l deferred.elc + +test-concurrent: + $(CASK) exec ert-runner test/concurrent-test.el + +test-concurrent-compiled: concurrent.elc + $(CASK) exec ert-runner test/concurrent-test.el -l concurrent.elc + +compile: deferred.elc concurrent.elc + +%.elc: %.el + $(EMACS) -batch -L . -f batch-byte-compile $< + +clean: + rm -rfv *.elc + +print-deps: + @echo "----------------------- Dependencies -----------------------" + $(EMACS) --version + @echo "------------------------------------------------------------" + +travis-ci: print-deps + $(MAKE) clean test + $(MAKE) compile test diff --git a/README-concurrent.ja.markdown b/README-concurrent.ja.markdown new file mode 100644 index 0000000..e8e8268 --- /dev/null +++ b/README-concurrent.ja.markdown @@ -0,0 +1,416 @@ +# concurrent.el # + +[![Build Status](https://travis-ci.org/kiwanami/emacs-deferred.svg)](https://travis-ci.org/kiwanami/emacs-deferred) +[![Coverage Status](https://coveralls.io/repos/kiwanami/emacs-deferred/badge.svg)](https://coveralls.io/r/kiwanami/emacs-deferred) +[![MELPA](http://melpa.org/packages/concurrent-badge.svg)](http://melpa.org/#/concurrent) +[![MELPA stable](http://stable.melpa.org/packages/concurrent-badge.svg)](http://stable.melpa.org/#/concurrent) +[![Tag Version](https://img.shields.io/github/tag/kiwanami/emacs-deferred.svg)](https://github.com/kiwanami/emacs-deferred/tags) +[![License](http://img.shields.io/:license-gpl3-blue.svg)](http://www.gnu.org/licenses/gpl-3.0.html) + +concurrent.elは、良くある非同期処理を抽象化したライブラリです。スレッド、セマフォ、イベント管理などがあります。他の環境のライブラリや並行プログラミングのアイデアを参考にしました。 + +## インストール ## + +concurrent.elは package.elを使って, [MELPA](http://melpa.org)からインストールすることができます. + +## 使い方例 ## + +以下のサンプルで例示したソースは concurrent-samples.el の中にあります。 +eval-last-sexp (C-x C-e) などで実行してみてください。 + +### Threadの例 + +lexical-letを評価するとその場でアニメーションします。引数の時間は、bodyの処理の間隔です。 + +Thread: + +```el +(lexical-let + ((count 0) (anm "-/|\\-") + (end 50) (pos (point))) + (cc:thread + 60 + (message "Animation started.") + (while (> end (incf count)) + (save-excursion + (when (< 1 count) + (goto-char pos) (delete-char 1)) + (insert (char-to-string + (aref anm (% count (length anm))))))) + (save-excursion + (goto-char pos) (delete-char 1)) + (message "Animation finished."))) +``` + +whileを使うことでスレッドをループさせることが出来ます。whileの中身は一気に実行されます。 + +無限ループや重い処理でEmacsが固まらないように注意してください。もし無限ループに突入してしまったり、固まってしまったら deferred:clear-queue コマンドで回復できる可能性があります。 + + +### Generatorの例 + +fib-genにジェネレーターを作ります。ジェネレーター生成body内のyield関数で値を返します。値はコールバックで値を受け取ります。 + +Generator: + +```el +(setq fib-list nil) +(setq fib-gen + (lexical-let ((a1 0) (a2 1)) + (cc:generator + (lambda (x) (push x fib-list)) ; コールバックで結果受け取り + (yield a1) + (yield a2) + (while t + (let ((next (+ a1 a2))) + (setq a1 a2 + a2 next) + (yield next)))))) + +(funcall fib-gen) ; 何度か呼んでみる +(funcall fib-gen) (funcall fib-gen) +(funcall fib-gen) (funcall fib-gen) + +fib-list ; => (3 2 1 1 0) +``` + +### Semaphoreの例 + +cc:semaphore-acquire 関数が deferred を返すので、それに続けて実行させたいタスクをつなげていきます。時系列で挙動が変わっていくのでコード中に簡単な説明を書いてみました。 + +Semaphore: + +```el +;; permit=1のセマフォ作成 +(setq smp (cc:semaphore-create 1)) + +;; 続けて3つ実行しようとする +(deferred:nextc (cc:semaphore-acquire smp) + (lambda(x) + (message "go1"))) +(deferred:nextc (cc:semaphore-acquire smp) + (lambda(x) + (message "go2"))) +(deferred:nextc (cc:semaphore-acquire smp) + (lambda(x) + (message "go3"))) + +;; => 1つ目だけ実行されて go1 が表示される + +(cc:semaphore-release smp) ; permitを返す + +;; => 2つ目が実行されて go2 が表示される + +(cc:semaphore-waiting-deferreds smp) ; go3 を表示するdeferred + +(cc:semaphore-release-all smp) ; => permitを初期化して go3 を表示するdeferredを返す + +(cc:semaphore-waiting-deferreds smp) ; => nil +``` + +### Dataflowの例： + +cc:dataflow-environment 関数で変数を格納する「環境」を作ります。 cc:dataflow-get は値の取得とそれに続くタスクをつなげる deferred を返します。 cc:dataflow-set で値をバインドします。例ではキーに文字列を使っていますが、キーには任意のオブジェクトを指定できます。 + +Dataflow: + +```el +(setq dfenv (cc:dataflow-environment)) + +;; ○基本の使い方 + +;; ↓同期的に値を取得。ブロックしない。 +(cc:dataflow-get-sync dfenv "abc") ; => nil まだ値が無い。 + +(deferred:$ ; abc という値を取ってきて表示する処理 + (cc:dataflow-get dfenv "abc") + (deferred:nextc it + (lambda (x) (message "Got abc : %s" x)))) +;; => 値がないので処理はブロックしたまま + +(cc:dataflow-set dfenv "abc" 256) ; 値をセット +;; => ここで先ほどブロックしていた処理が再開し、 "Got abc : 256" が表示される + +(cc:dataflow-get-sync dfenv "abc") ; => 256 + +(cc:dataflow-clear dfenv "abc") ; 値を未バインドに戻す + +(cc:dataflow-get-sync dfenv "abc") ; => nil + +;; ○リストをキーにする + +(deferred:$ + (cc:dataflow-get dfenv '("http://example.com/a.jpg" 300)) + (deferred:nextc it + (lambda (x) (message "a.jpg:300 OK %s" x)))) + +(cc:dataflow-set dfenv '("http://example.com/a.jpg" 300) 'jpeg) + +;; => a.jpg:300 OK jpeg + +;; ○2つの値を待ち受ける + +(deferred:$ ; abc, def の2つの値を使う + (deferred:parallel + (cc:dataflow-get dfenv "abc") + (cc:dataflow-get dfenv "def")) + (deferred:nextc it + (lambda (values) + (apply 'message "Got values : %s, %s" values) + (apply '+ values))) + (deferred:nextc it + (lambda (x) (insert (format ">> %s" x))))) +;; => もちろんブロックする + +(cc:dataflow-get-waiting-keys dfenv) ; => ("def" "abc") +(cc:dataflow-get-avalable-pairs dfenv) ; => ((("http://example.com/a.jpg" 300) . jpeg)) + +(cc:dataflow-set dfenv "abc" 128) ; ここではまだブロックしたまま +(cc:dataflow-set dfenv "def" 256) ; ここでやっと動く +;; => Got values : 128, 256 +``` + +### Signalの例： + +cc:signal-channel でシグナルを流すチャンネルを作成します。その後、signalに応答する処理を接続していきます。 + +```el +;; シグナルのチャンネルを作成 +(setq channel (cc:signal-channel)) + +(cc:signal-connect ; foo というシグナルを拾う + channel 'foo + (lambda (event) (message "Signal : %S" event))) + +(cc:signal-connect + channel t ; t にするとすべてのシグナルを拾う + (lambda (event) + (destructuring-bind (event-name (args)) event + (message "Listener : %S / %S" event-name args)))) + +(deferred:$ ; deferred で非同期タスクを接続できる + (cc:signal-connect channel 'foo) + (deferred:nextc it + (lambda (x) (message "Deferred Signal : %S" x)))) + +(cc:signal-send channel 'foo "hello signal!") +;; => +;; Listener : foo / "hello signal!" +;; Signal : (foo ("hello signal!")) +;; Deferred Signal : (foo ("hello signal!")) + +(cc:signal-send channel 'some "some signal!") +;; => +;; Listener : some / "some signal!" +``` + +dataflowの内部には、変数へのアクセスやバインドのシグナルを発信するchannelがあります。これを使って、未バインドの変数に値を作成してセットするようなことが出来ます。 + +signalやdataflowは、カスケード接続して親子関係を構築できます。例えば、親dataflowにデフォルト値（フォールバックの値）を入れておくとか、channelで親子関係を構築してローカルなイベントとグローバルなイベントを分けて効率的にイベントを管理するなどが出来ます。 + +## インタフェース解説 ## + +### Thread + +* cc:thread (wait-time-msec &rest body) + * 引数： + * wait-time-msec: タスク間の間隔（ミリ秒） + * 返値：Threadオブジェクト（今のところ使い道無し） + * スレッドを作成して開始します + * bodyのS式が一つずつ非同期で実行されます。その間隔が wait-time-msec で指定された時間です。 + * bodyの中に while があった場合は、特別にループとして処理します。 + * 無限ループや重い処理でEmacsが固まらないように注意してください。もし無限ループに突入してしまったり、固まってしまったら deferred:clear-queue コマンドで回復できる可能性があります。 + +### Generator + +* cc:generator (callback &rest body) + * 引数： + * callback: yieldした値を受け取る関数 + * body: Generatorの中身 + * 返値：Generatorを実行する関数 + * Threadと同様に、bodyのS式が一つずつ非同期で実行されます。 + * bodyの中に while があった場合は、特別にループとして処理します。 + * bodyの内で yield 関数を使う（実際にはマクロで置換されます）と、callbackで指定した関数に値が渡って処理が停止します。 + * 再度 Generator 関数を実行すると停止した位置から開始します。 + +### Semaphore + +* cc:semaphore-create (permits-num) + * 引数： + * permits-num: 許可数 + * 返値：Semaphoreオブジェクト + * セマフォオブジェクトを作成します。 + +* cc:semaphore-acquire (semaphore) + * 引数： + * semaphore: Semaphoreオブジェクト + * 返値：Deferredオブジェクト + * 返したDeferredオブジェクトに、実行数を制限したいタスクをつなげます。 + * 実行する際、許可数を1つ消費します。許可数が0になったら、以降のタスクは待たされます。 + * 実行可能なら、返したDeferredタスクがすぐに実行されます。 + * 実行可能でなければ、許可数が戻るまで返したDeferredタスクは待たされます。 + +* cc:semaphore-release (semaphore) + * 引数： + * semaphore: Semaphoreオブジェクト + * 返値：Semaphoreオブジェクト + * 許可数を一つ戻します。その際、待っているタスクがあれば実行されます。 + * 許可数は自動では戻りませんので、 cc:semaphore-release を呼ぶのはプログラマの責任です。 + +* cc:semaphore-with (semaphore body-func &optional error-func) + * 引数： + * semaphore: Semaphoreオブジェクト + * body-func: 実行数を制御したいタスクの関数 + * error-func: 発生したエラーを処理する関数（deferred:errorで接続される） + * 返値：Deferredオブジェクト + * acquireとreleaseを前後で行う関数です。特に理由がない限りは、acquireとreleaseを自分で書くよりも、こちらを使う方が安全で楽です。 + + +* cc:semaphore-release-all (semaphore) + * 引数： + * semaphore: Semaphoreオブジェクト + * 返値：実行待ちだったDeferredオブジェクト + * 許可数を強制的に初期値に戻します。デバッグ時や状態をリセットしたいときに使います。 + +* cc:semaphore-interrupt-all (semaphore) + * 引数： + * semaphore: Semaphoreオブジェクト + * 返値：Deferredオブジェクト + * 実行待ちのタスクがなければ、すぐに実行するDeferredオブジェクトを返します。 + * 現在実行待ちのタスクがあれば取り除いて、現在実行中のタスクの次に実行されるDeferredオブジェクトを返します。 + * 割り込みしたいときに使います。 + +### Signal + +* cc:signal-channel (&optional name parent-channel) + * 引数： + * name: このチャンネルの名前。主にデバッグ用。 + * parent-channel: 上流のチャンネルオブジェクト。 + * 返値：チャンネルオブジェクト + * 新しいチャンネルを作成します。 + * 上流のシグナルは下流に流れてきますが、下流から上流には cc:signal-send-global を使わない限り流れません。 + +* cc:signal-connect (channel event-sym &optional callback) + * 引数： + * channel: チャンネルオブジェクト + * event-sym: イベント識別シンボル + * callback: 受け取り関数 + * 返値：Deferredオブジェクト + * シグナルを受信するタスクを追加します。 + * event-sym が t の場合は、すべてのシグナルを受信します。 + * 通常はこの関数の返値にシグナルを受信する非同期タスクを接続します。 + +* cc:signal-send (channel event-sym &rest args) + * 引数： + * channel: チャンネルオブジェクト + * event-sym: イベント識別シンボル + * args: イベント引数 + * 返値：なし + * シグナルを発信します。 + * args は、受信側で (lambda (event) (destructuring-bind (event-sym (args)) event ... )) のようにすると受け取れます。 + + +* cc:signal-send-global (channel event-sym &rest args) + * 引数： + * channel: チャンネルオブジェクト + * event-sym: イベント識別シンボル + * args: イベント引数 + * 返値：なし + * 上流のチャンネルにシグナルを送信します。 + +* cc:signal-disconnect (channel deferred) + * 引数： + * channel: チャンネルオブジェクト + * deferred: チャンネルから取り除きたいDeferredオブジェクト + * 返値：削除されたDeferredオブジェクト + * チャンネルから受信タスクを取り除きます。 + +* cc:signal-disconnect-all (channel) + * 引数： + * channel: チャンネルオブジェクト + * 返値：なし + * すべての受信タスクを取り除きます。 + +### Dataflow + +* cc:dataflow-environment (&optional parent-env test-func channel) + * 引数： + * parent-env: デフォルト値として使うDataflowオブジェクト + * test-func: keyの比較関数 + * channel: チャンネルオブジェクト + * 返値：Dataflowオブジェクト + * 新しくDataflowオブジェクトを作成して返します。 + * channelは引数で与えなかった場合は、内部新しいチャンネルオブジェクトを作成します。 + * 以下のシグナルがチャンネルに送信されます + * get-first : 初回未バインド変数を参照したとき + * get-waiting : 2回目以降の未バインド変数を参照したとき + * set : 値をバインドしたとき + * get : バインドされた値を参照したとき + * clear : バインド解除されたとき + * clear-all : すべてのバインドが解除されたとき + +* cc:dataflow-get (df key) + * 引数： + * df: Dataflowオブジェクト + * key: 変数キー + * 返値：変数の値を受け取るDeferredオブジェクト + * 変数の値を受け取るDeferredタスクを返すので、変数の値を使う処理を接続します。 + * 変数の値がバインドされていれば、直ちに実行されます。 + * 変数の値がバインドされていなければ、返されたDeferredタスクはバインドされるまで実行されません。 + +* cc:dataflow-get-sync (df key) + * 引数： + * df: Dataflowオブジェクト + * key: 変数キー + * 返値：nil か値 + * 変数の値を同期的に参照します。 + * 値がバインドされていなければ nil を返します。 + +* cc:dataflow-set (df key value) + * 引数： + * df: Dataflowオブジェクト + * key: 変数キー + * value: 値 + * 返値：なし + * 変数に値をバインドします。 + * もし、すでにバインドされている変数にバインドしようとした場合はエラーが発生します。 + +* cc:dataflow-clear (df key) + * 引数： + * df: Dataflowオブジェクト + * key: 変数キー + * 返値：なし + * 変数を未バインドに戻します。 + +* cc:dataflow-get-avalable-pairs (df) + * 引数： + * df: Dataflowオブジェクト + * 返値：バインドされている変数キーと値の alist + +* cc:dataflow-get-waiting-keys (df) + * 引数： + * df: Dataflowオブジェクト + * 返値：未バインドで、受け取り待ちのタスクが存在する変数キーのリスト + +* cc:dataflow-clear-all (df) + * 引数： + * df: Dataflowオブジェクト + * 返値：なし + * 指定されたDataflowオブジェクトを空にします。 + * 受け取り待ちのタスクについては何もしません。 + +* cc:dataflow-connect (df event-sym &optional callback) + * 引数： + * df: Dataflowオブジェクト + * event-sym: イベント識別シンボル + * callback: 受け取り関数 + * 返値：Deferredオブジェクト + * このDataflowオブジェクトのチャンネルにシグナル受け取りタスクを追加します。 + * 内部で cc:signal-connect を呼びます。 + * 受け取れるイベント識別シンボルについては、 cc:dataflow-environment を参照してください。 + + +* * * * * + +(C) 2011-2016 SAKURAI Masashi All rights reserved. +m.sakurai at kiwanami.net diff --git a/README-concurrent.markdown b/README-concurrent.markdown new file mode 100644 index 0000000..c3917bf --- /dev/null +++ b/README-concurrent.markdown @@ -0,0 +1,463 @@ +# concurrent.el + +[![Build Status](https://travis-ci.org/kiwanami/emacs-deferred.svg)](https://travis-ci.org/kiwanami/emacs-deferred) +[![Coverage Status](https://coveralls.io/repos/kiwanami/emacs-deferred/badge.svg)](https://coveralls.io/r/kiwanami/emacs-deferred) +[![MELPA](http://melpa.org/packages/concurrent-badge.svg)](http://melpa.org/#/concurrent) +[![MELPA stable](http://stable.melpa.org/packages/concurrent-badge.svg)](http://stable.melpa.org/#/concurrent) +[![Tag Version](https://img.shields.io/github/tag/kiwanami/emacs-deferred.svg)](https://github.com/kiwanami/emacs-deferred/tags) +[![License](http://img.shields.io/:license-gpl3-blue.svg)](http://www.gnu.org/licenses/gpl-3.0.html) + +`concurrent.el` is a higher level library for asynchronous tasks, based on `deferred.el`. + +It is inspired by libraries of other environments and concurrent programing models. +It has following facilities: *pseud-thread*, *generator*, *semaphore*, *dataflow variables* and +*event management*. + +## Installation ## + +You can install `concurrent.el` from [MELPA](http://melpa.org) by `package.el`. + +## Sample codes ## + +You can find following sample codes in `concurrent-sample.el`. +Executing `eval-last-sexp` (C-x C-e), you can try those codes. + +### Pseud-thread + +Evaluating the lexical-let in the blow code, the animation starts. After few seconds, the animation will stop. + +Thread: + +```el +(lexical-let + ((count 0) (anm "-/|\\-") + (end 50) (pos (point))) + (cc:thread + 60 + (message "Animation started.") + (while (> end (incf count)) + (save-excursion + (when (< 1 count) + (goto-char pos) (delete-char 1)) + (insert (char-to-string + (aref anm (% count (length anm))))))) + (save-excursion + (goto-char pos) (delete-char 1)) + (message "Animation finished."))) +``` + +Using `while` clause in the body content, one can make a loop in the thread. + +Be careful not to make an infinite loop or heavy loop accidentally. If you find that the Emacs enters infinite loop, you may be able to stop the loop with executing the command `deferred:clear-queue`. + +### Generator + +The following code creates a generator object and binds it to the variable `fib-gen`. +One can receive values, using `yield` function in the generator body code. +When the generator returns a value, the evaluation process stops. +Calling generator object as a function, the evaluation process resumes. + +Generator: + +```el +(setq fib-list nil) +(setq fib-gen + (lexical-let ((a1 0) (a2 1)) + (cc:generator + (lambda (x) (push x fib-list)) ; Receiving values as a callback function + (yield a1) + (yield a2) + (while t + (let ((next (+ a1 a2))) + (setq a1 a2 + a2 next) + (yield next)))))) + +(funcall fib-gen) ; calling 5 times +(funcall fib-gen) (funcall fib-gen) +(funcall fib-gen) (funcall fib-gen) + +fib-list ; => (3 2 1 1 0) +``` + +### Semaphore + +The semaphore restricts the number of concurrent tasks. +The following code creates a semaphore object with one permit, and binds it to the variable `smp`. +The subsequent codes and comments show how the semaphore object works. + +Semaphore: + +```el +;; Create a semaphore with permit=1. +(setq smp (cc:semaphore-create 1)) + +;; Start three tasks with acquiring permit. +(deferred:nextc (cc:semaphore-acquire smp) + (lambda(x) + (message "go1"))) +(deferred:nextc (cc:semaphore-acquire smp) + (lambda(x) + (message "go2"))) +(deferred:nextc (cc:semaphore-acquire smp) + (lambda(x) + (message "go3"))) + +;; => Only the first task is executed and displays "go1". +;; Rest ones are blocked. + +(cc:semaphore-release smp) ; Releasing one permit + +;; => The second task is executed, then, displays "go2". + +(cc:semaphore-waiting-deferreds smp) ; => The third task object + +(cc:semaphore-release-all smp) ; => Reset permits and return the third task object + +(cc:semaphore-waiting-deferreds smp) ; => nil +``` + +### Dataflow + +The function `cc:dataflow-environment` creates an environment for dataflow variables. +The function `cc:dataflow-get` returns a deferred object that can refer the value. +The function `cc:dataflow-set` binds a value to a dataflow variable. +Any objects can be variable keys in the environment. This sample code uses strings as keys. + +Dataflow: + +```el +;; Create an environment. +(setq dfenv (cc:dataflow-environment)) + +;;## Basic usage + +;; Referring a variable synchronously. This function doesn't block. +(cc:dataflow-get-sync dfenv "abc") ; => nil + +(deferred:$ ; Start the task that gets the value of `abc` and that displays the value. + (cc:dataflow-get dfenv "abc") + (deferred:nextc it + (lambda (x) (message "Got abc : %s" x)))) +;; => This task is blocked because no value is bound to the variable `abc`. + +(cc:dataflow-set dfenv "abc" 256) ; Binding a value to the variable `abc`. +;; => The blocked task resumes and displays "Got abc : 256". + +(cc:dataflow-get-sync dfenv "abc") ; => 256 + +(cc:dataflow-clear dfenv "abc") ; unbind the variable `abc` + +(cc:dataflow-get-sync dfenv "abc") ; => nil + +;;## Complex key + +(deferred:$ + (cc:dataflow-get dfenv '("http://example.com/a.jpg" 300)) + (deferred:nextc it + (lambda (x) (message "a.jpg:300 OK %s" x)))) + +(cc:dataflow-set dfenv '("http://example.com/a.jpg" 300) 'jpeg) + +;; => a.jpg:300 OK jpeg + +;;## Waiting for two variables + +(deferred:$ ; Start the task that refers two variables, `abc` and `def`. + (deferred:parallel + (cc:dataflow-get dfenv "abc") + (cc:dataflow-get dfenv "def")) + (deferred:nextc it + (lambda (values) + (apply 'message "Got values : %s, %s" values) + (apply '+ values))) + (deferred:nextc it + (lambda (x) (insert (format ">> %s" x))))) +;; => This task is blocked. + +(cc:dataflow-get-waiting-keys dfenv) ; => ("def" "abc") +(cc:dataflow-get-avalable-pairs dfenv) ; => ((("http://example.com/a.jpg" 300) . jpeg)) + +(cc:dataflow-set dfenv "abc" 128) ; Binding one value. The task is still blocked. +(cc:dataflow-set dfenv "def" 256) ; Binding the next value. Then, the task resumes. +;; => Got values : 128, 256 +``` + +### Signal + +The function `cc:signal-channel` creates a channel for signals. +Then, one can connect receivers and send signals. + +Signal: + +```el +;; Create a channel. +(setq channel (cc:signal-channel)) + +(cc:signal-connect ; Connect the receiver for the signal 'foo. + channel 'foo + (lambda (event) (message "Signal : %S" event))) + +(cc:signal-connect + channel t ; The signal symbol 't' means any signals. + (lambda (event) + (destructuring-bind (event-name (args)) event + (message "Listener : %S / %S" event-name args)))) + +(deferred:$ ; Connect the deferred task. + (cc:signal-connect channel 'foo) + (deferred:nextc it + (lambda (x) (message "Deferred Signal : %S" x)))) + +(cc:signal-send channel 'foo "hello signal!") +;; => +;; Listener : foo / "hello signal!" +;; Signal : (foo ("hello signal!")) +;; Deferred Signal : (foo ("hello signal!")) + +(cc:signal-send channel 'some "some signal!") +;; => +;; Listener : some / "some signal!" +``` + +Dataflow objects have the own channel to notify accessing to the variables. +Receiving the signals for referring unbound variables, one can create values on demand. + +The signal and dataflow objects can be cascades, creating objects with the parent ones. +It enables that the dataflow object can have the default values, and that +one can use the different scope signals in the tree structure of the channel objects, such as global signals and local signals. + +## API Details + +### Thread + +* cc:thread (wait-time-msec &rest body) + * Arguments + * wait-time-msec: The interval time between tasks (millisecond). + * Return + * A thread object. + * This function creates a thread and start it. + * The `thread` means that each s-exps in the body part are executed as asynchronous tasks. Then, the interval between tasks is `wait-time-msec`. + * The `while` form in the body part acts as a loop. + * Note that the infinite loops or the heavy loop tasks may make the Emacs freeze. The command `deferred:clear-queue` may recover such freeze situation. + +### Generator + +* cc:generator (callback &rest body) + * Arguments + * callback: A function to receive the value passed by `yield` form. + * body: Generator forms. + * Return + * A generating function. + * Similar to `cc:thread`, each s-exps in the body part are executed as asynchronous tasks and the `while` form in the body part acts as a loop. + * The `yield` form in the body part passes the value to the `callback` function and pause the asynchronous tasks. + * Calling the generating function, the asynchronous tasks resume. + +### Semaphore + +* cc:semaphore-create (permits-num) + * Arguments + * permits-num: The number of permits. + * Return + * A semaphore object. + * This function creates a semaphore object. + +* cc:semaphore-acquire (semaphore) + * Argument + * semaphore: A semaphore object. + * Return + * A deferred object. + * Acquire an execution permission and return deferred object to chain. + * If this semaphore object has permissions, the subsequent deferred task is executed immediately. + * If this semaphore object has no permissions, the subsequent deferred task is blocked. After the permission is returned, the task is executed. + +* cc:semaphore-release (semaphore) + * Arguments + * semaphore: A semaphore object + * Return + * The given semaphore object + * Release an execution permission. + * The programmer is responsible to return the permissions. + +* cc:semaphore-with (semaphore body-func &optional error-func) + * Arguments + * semaphore: A semaphore object + * body-func: A task function + * error-func: An error handling function (which is connected by `deferred:error`.) + * Return + * A deferred object + * Execute the task function asynchronously with the semaphore block. + * Using this function is bit safer than using a pair of `cc:semaphore-acquire` and `cc:semaphore-release`. + +* cc:semaphore-release-all (semaphore) + * Arguments + * semaphore: A semaphore object + * Return + * Deferred objects those were waiting for permission. + * Release all permissions for resetting the semaphore object. + * If the semaphore object has some blocked tasks, this function return a list of the tasks and clear the list of the blocked tasks in the semaphore object. + +* cc:semaphore-interrupt-all (semaphore) + * Arguments + * semaphore: A semaphore object + * Return + * A deferred object + * Clear the list of the blocked tasks in the semaphore and return a deferred object to chain. + * This function is used for the interruption cases. + +### Signal + +* cc:signal-channel (&optional name parent-channel) + * Arguments + * name: A channel name for debug. + * parent-channel: An upstream channel object. + * Return + * A channel object. + * Create a new channel object. + * The observers of this channel can receive the upstream signals. + * In the case of using the function `cc:signal-send`, the observers of the upstream channel can not receive the signals of this channel. + * The function `cc:signal-send-global` can send a signal to the upstream channels from the downstream channels. + +* cc:signal-connect (channel event-sym &optional callback) + * Arguments + * channel: A channel object + * event-sym: A signal symbol + * callback: A receiver function + * Return + * A deferred object + * Append an observer for the symbol of the channel and return a deferred object. + * If `event-sym` is `t`, the observer receives all signals of the channel. + * If the callback function is given, the deferred object executes the callback function asynchronously. + * One can connect subsequent tasks to the returned deferred object. + +* cc:signal-send (channel event-sym &rest args) + * Arguments + * channel: A channel object + * event-sym: A signal symbol + * args: Signal arguments + * Return + * None + * Send a signal to the channel. + * If the `args` are given, observers can get the values by following code: + * `(lambda (event) (destructuring-bind (event-sym (args)) event ... ))` + +* cc:signal-send-global (channel event-sym &rest args) + * Arguments + * channel: A channel object + * event-sym: A signal symbol + * args: Signal arguments + * Return + * None + * Send a signal to the most upstream channel. + +* cc:signal-disconnect (channel deferred) + * Arguments + * channel: A channel object + * deferred: The deferred object to delete + * Return + * The deleted deferred object + * Remove the observer object from the channel and return the removed deferred object. + +* cc:signal-disconnect-all (channel) + * Arguments + * channel: A channel object + * Return + * None + * Remove all observers. + +### Dataflow + +* cc:dataflow-environment (&optional parent-env test-func channel) + * Arguments + * parent-env: A dataflow object as the default value. + * test-func: A test function that compares the entry keys. + * channel: A channel object that sends signals of variable events. + * Return + * A dataflow object + * Create a dataflow environment. + * The parent environment + * If this environment doesn't have the entry A and the parent one has the entry A, this environment can return the entry A. + * One can override the entry, setting another entry A to this environment. + * If no channel is given, this function creates a new channel object internally. + * Observers can receive following signals: + * `get-first` : the fist referrer is waiting for binding, + * `get-waiting` : another referrer is waiting for binding, + * `set` : a value is bound, + * `get` : returned a bound value, + * `clear` : cleared one entry, + * `clear-all` : cleared all entries. + +* cc:dataflow-get (df key) + * Arguments + * df: A dataflow object + * key: A key object + * Return + * A deferred object + * Return a deferred object that can refer the value which is indicated by the key. + * If the dataflow object has the entry that bound value, the subsequent deferred task is executed immediately. + * If not, the task is deferred till a value is bound. + +* cc:dataflow-get-sync (df key) + * Arguments + * df: A dataflow object + * key: A key object + * Return + * Nil or a value + * Return the value which is indicated by the key synchronously. + * If the environment doesn't have an entry of the key, this function returns nil. + +* cc:dataflow-set (df key value) + * Arguments + * df: A dataflow object + * key: A key object + * value: A value + * Return + * None + * Bind the value to the key in the environment. + * If the dataflow already has the bound entry of the key, this function throws an error signal. + * The value can be nil as a value. + +* cc:dataflow-clear (df key) + * Arguments + * df: A dataflow object + * key: A key object + * Return + * None + * Clear the entry which is indicated by the key. + * This function does nothing for the waiting deferred objects. + +* cc:dataflow-get-avalable-pairs (df) + * Arguments + * df: A dataflow object + * Return + * An available key-value alist in the environment and the parent ones. + +* cc:dataflow-get-waiting-keys (df) + * Arguments + * df: A dataflow object + * Return + * A list of keys which have waiting deferred objects in the environment and the parent ones. + +* cc:dataflow-clear-all (df) + * Arguments + * df: A dataflow object + * Return + * None + * Clear all entries in the environment. + * This function does nothing for the waiting deferred objects. + +* cc:dataflow-connect (df event-sym &optional callback) + * Arguments + * df: A dataflow object + * event-sym: A signal symbol + * callback: A receiver function + * Return + * A deferred object + * Append an observer for the symbol of the channel of the environment and return a deferred object. + * See the document of `cc:dataflow-environment` for details of signals. + + +* * * * * + +(C) 2011-2016 SAKURAI Masashi All rights reserved. +m.sakurai at kiwanami.net diff --git a/README.ja.markdown b/README.ja.markdown new file mode 100644 index 0000000..0ce24c2 --- /dev/null +++ b/README.ja.markdown @@ -0,0 +1,669 @@ +# deferred.el # + +[![Build Status](https://travis-ci.org/kiwanami/emacs-deferred.svg)](https://travis-ci.org/kiwanami/emacs-deferred) +[![Coverage Status](https://coveralls.io/repos/kiwanami/emacs-deferred/badge.svg)](https://coveralls.io/r/kiwanami/emacs-deferred) +[![MELPA](http://melpa.org/packages/deferred-badge.svg)](http://melpa.org/#/deferred) +[![MELPA stable](http://stable.melpa.org/packages/deferred-badge.svg)](http://stable.melpa.org/#/deferred) +[![Tag Version](https://img.shields.io/github/tag/kiwanami/emacs-deferred.svg)](https://github.com/kiwanami/emacs-deferred/tags) +[![License](http://img.shields.io/:license-gpl3-blue.svg)](http://www.gnu.org/licenses/gpl-3.0.html) + +deferred.elは非同期処理を抽象化して書きやすくするためのライブラリです。APIや +実装については +[JSDeferred](https://github.com/cho45/jsdeferred "JSDeferred") (by cho45さん)と +[Mochikit.Async](http://mochikit.com/doc/html/MochiKit/Async.html +"Mochikit.Async") (by Bob Ippolitoさん)を参考にしています。 + +## インストール ## + +deferred.elは package.elを使って, [MELPA](http://melpa.org)からインストールすることができます. + +## 使い方例 ## + +以下のサンプルで例示したソースは deferred-samples.el の中にあります。 +eval-last-sexp (C-x C-e) などで実行してみてください。 + +### 基本 ### + +基本的な deferred の連結です。messageにいくつか表示し、ミニバッファから +入力を受け付けます。 + +Chain: + +```el +(deferred:$ + (deferred:next + (lambda () (message "deferred start"))) + (deferred:nextc it + (lambda () + (message "chain 1") + 1)) + (deferred:nextc it + (lambda (x) + (message "chain 2 : %s" x))) + (deferred:nextc it + (lambda () + (read-minibuffer "Input a number: "))) + (deferred:nextc it + (lambda (x) + (message "Got the number : %i" x))) + (deferred:error it + (lambda (err) + (message "Wrong input : %s" err)))) +``` + + +* この式を実行すると、直ちに結果が帰ってきます。 + * 実際の処理自体はすぐ後に非同期で実行されます。 +* deferred:$ は deferred を連結するためのマクロです。 + * itには前の式(deferred:nextなど)の返値が入っています。 +* 前の deferred 処理の返値が、次の処理の引数になっています。 +* 数字以外を入力するとエラーになりますが、 deferred:error でエラーを拾っています。 + + +### タイマーで一定時間後 ### + +1秒待ってメッセージを表示します。 + +Timer: + +```el +(deferred:$ + (deferred:wait 1000) ; 1000msec + (deferred:nextc it + (lambda (x) + (message "Timer sample! : %s msec" x)))) +``` + +* deferred:wait の次の処理には、実際に経過した時間が渡ってきます。 + +### 外部プロセス・コマンド実行 ### + +外部プロセスで「ls -la」を実行して結果を現在のバッファに表示します。（素のWindowsで動かす場合は、dirなどに変更してみてください。） + +Command process: + +```el +(deferred:$ + (deferred:process "ls" "-la") + (deferred:nextc it + (lambda (x) (insert x)))) +``` + +* 非同期で実行するため、処理がブロックしたりしません。 + + +### HTTP GET ### + +GNUのトップページのHTMLを取ってきて、現在のバッファに貼り付けます（大量のHTMLが張り付きますが、undoで戻せます）。 + +HTTP GET: + +```el +(require 'url) + +(deferred:$ + (deferred:url-retrieve "http://www.gnu.org") + (deferred:nextc it + (lambda (buf) + (insert (with-current-buffer buf (buffer-string))) + (kill-buffer buf)))) +``` + +### 画像 ### + +googleの画像を取ってきてそのままバッファに貼り付けます。 + +Get an image: + +```el +(deferred:$ + (deferred:url-retrieve "http://www.google.co.jp/intl/en_com/images/srpr/logo1w.png") + (deferred:nextc it + (lambda (buf) + (insert-image + (create-image + (let ((data (with-current-buffer buf (buffer-string)))) + (substring data (+ (string-match "\n\n" data) 2))) + 'png t)) + (kill-buffer buf)))) +``` + +### 並列 ### + +2つの画像を取ってきて、結果がそろったところで各画像のファイルサイズを現在のバッファに表示します。 + +Parallel deferred: + +```el +(deferred:$ + (deferred:parallel + (lambda () + (deferred:url-retrieve "http://www.google.co.jp/intl/en_com/images/srpr/logo1w.png")) + (lambda () + (deferred:url-retrieve "http://www.google.co.jp/images/srpr/nav_logo14.png"))) + (deferred:nextc it + (lambda (buffers) + (loop for i in buffers + do + (insert + (format + "size: %s\n" + (with-current-buffer i (length (buffer-string))))) + (kill-buffer i))))) +``` + +* deferred:parallel 内部で、並列に実行できるものは並列に動作します。 +* 各処理が完了するかエラーが発生して、すべての処理が完了したところで次の処理が開始されます。 +* 次の処理には結果がリストで渡されます。 + * 順番は保持されます + * alistを渡して名前で結果を選ぶことも出来ます + +### deferred組み合わせ、try-catch-finally ### + +外部プロセスの wget で画像を取ってきて、ImageMagic の convert コマンドでリサイズし、バッファに画像を表示します。（wget, convertが無いと動きません） +deferred を組み合わせて、非同期処理の try-catch のような構造を作ることが出来ます。 + +Get an image by wget and resize by ImageMagick: + +```el +(deferred:$ + + ;; try + (deferred:$ + (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png") + (deferred:nextc it + (lambda () (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg"))) + (deferred:nextc it + (lambda () + (clear-image-cache) + (insert-image (create-image (expand-file-name "b.jpg") 'jpeg nil))))) + + ;; catch + (deferred:error it ; + (lambda (err) + (insert "Can not get a image! : " err))) + + ;; finally + (deferred:nextc it + (lambda () + (deferred:parallel + (lambda () (delete-file "a.jpg")) + (lambda () (delete-file "b.jpg"))))) + (deferred:nextc it + (lambda (x) (message ">> %s" x)))) +``` + +* deferred を静的につなげることで、自由に組み合わせることが出来ます。 + * 関数などで個別の deferred 処理を作って、後で一つにまとめるなど。 + +なお、この例は以下のようにも書けます。（注意：完全に同じ動作ではありません。また、非同期の仕組み上、finallyタスクは必ず実行することを保証するものではありません。） + +Try-catch-finally: + +```el +(deferred:$ + (deferred:try + (deferred:$ + (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png") + (deferred:nextc it + (lambda () (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg"))) + (deferred:nextc it + (lambda () + (clear-image-cache) + (insert-image (create-image (expand-file-name "b.jpg") 'jpeg nil))))) + :catch + (lambda (err) (insert "Can not get a image! : " err)) + :finally + (lambda () + (delete-file "a.jpg") + (delete-file "b.jpg"))) + (deferred:nextc it + (lambda (x) (message ">> %s" x)))) +``` + +### earlierでtimeout ### + +外部プロセスで3秒待つコマンドを実行しますが、途中でキャンセルします。 + +deferred:earlier は parallel と同様に、引数の処理を並列に実行しますが、一番早く完了した処理の結果を次の処理に渡します。他の処理はその時点でキャンセルされます。 + +Timeout Process: + +```el +(deferred:$ + (deferred:earlier + (deferred:process "sh" "-c" "sleep 3 | echo 'hello!'") + (deferred:$ + (deferred:wait 1000) ; timeout msec + (deferred:nextc it (lambda () "canceled!")))) + (deferred:nextc it + (lambda (x) (insert x)))) +``` + +* deferred:wait の待つ時間を5秒などにすると、コマンドの結果が渡ってきます。 +* エラーは完了と見なされません。すべての処理がエラーになった場合は nil が次に渡ります。 +* deferred:parallel と deferred:earlier は lisp の and や or のようなイメージです。 + +なお、この例は deferred:timeout マクロを使って以下のようにも書けます。 + +Timeout macro: + +```el +(deferred:$ + (deferred:timeout + 1000 "canceled!" + (deferred:process "sh" "-c" "sleep 3 | echo 'hello!'")) + (deferred:nextc it + (lambda (x) (insert x)))) +``` + +### ループとアニメーション・スレッド ### + +数秒間カーソールのある位置に文字でアニメーションを表示します。その間、カーソールを自由に動かして普通にEmacsを操作できます。 + +deferredの処理の中でdeferredオブジェクトを返すと、ソースコードで（静的に）繋がっている次のdeferred処理へ移る前に、返した方のdeferredオブジェクトを実行します（動的なdeferredの接続）。再帰的な構造にしてwaitを入れて負荷を調節することで、マルチスレッドのような処理を実現することが出来ます。 + +Loop and animation: + +```el +(lexical-let ((count 0) (anm "-/|\\-") + (end 50) (pos (point)) + (wait-time 50)) + (deferred:$ + (deferred:next + (lambda (x) (message "Animation started."))) + + (deferred:nextc it + (deferred:lambda (x) + (save-excursion + (when (< 0 count) + (goto-char pos) (delete-char 1)) + (insert (char-to-string + (aref anm (% count (length anm)))))) + (if (> end (incf count)) ; 止める場合はdeferredでないものを返す（この場合はnil） + (deferred:nextc (deferred:wait wait-time) self)))) ; 続けるときはdeferredを返す + + (deferred:nextc it + (lambda (x) + (save-excursion + (goto-char pos) (delete-char 1)) + (message "Animation finished."))))) +``` + +* deferred:lambda は自分自身をselfとして使えるマクロです。再帰的構造を作るのに便利です。 + +## インタフェース解説 ## + +「関数」の章では各関数の簡単な説明を行います。「実行・接続」の章では、deferredオブジェクトの接続（実行順序）などの説明を行います。 + +### 関数 ### + +#### 基本 #### + +良く使用する基本的な関数やマクロです。 + +* deferred:next (callback) + * 引数： + * callback: 引数1つか0個の関数 + * 返値：deferredオブジェクト + * 引数の関数をコールバックとしてラップしたdeferredオブジェクトを生成して返します。また実行キューに入れて非同期実行をスケジュールします。 + * →関数を非同期で実行します。 + + +* deferred:nextc (d callback) + * 引数： + * d: deferredオブジェクト + * callback: 引数1つか0個の関数 + * 返値：deferredオブジェクト + * 引数の関数をコールバックとしてラップしたdeferredオブジェクトを生成し、引数のdeferredオブジェクトに接続して返します。 + * →前のdeferredの後に関数を実行するように連結します。 + +* deferred:error (d errorback) + * 引数： + * d: deferredオブジェクト + * errorback: 引数1つか0個の関数 + * 返値：deferredオブジェクト + * 引数の関数をエラー処理コールバックとしてラップしたdeferredオブジェクトを生成し、引数のdeferredオブジェクトに接続して返します。 + * →前のdeferredでエラーが起きたときに、この関数で処理するようにします。 + * この関数内で例外を発生しなければ、後続のdeferredのコールバック関数が実行されます。 + +* deferred:cancel (d) + * 引数： + * d: deferredオブジェクト + * 返値：引数のdeferredオブジェクト（無効になっている） + * 引数のdeferredオブジェクトを無効にして、コールバックやエラーバック関数が実行されないようにします。 + * この関数は引数のdeferredオブジェクトを破壊的に変更します。 + +* deferred:watch (d callback) + * 引数： + * d: deferredオブジェクト + * callback: 引数1つか0個の関数 + * 返値：deferredオブジェクト + * 引数の関数をコールバックとエラーバックの両方でラップしたdeferredオブジェクトを生成し、引数のdeferredオブジェクトに接続して返します。 + * 次のdeferredタスクへの値は前のタスクの結果をそのまま渡します。 + * callbackが何を返しても、callback内部でエラーが発生しても、deferredの流れに影響を与えません。 + * callback内部の非同期タスクは後続のdeferredタスクと非同期に実行されます。 + * →deferred処理の流れに割り込んだり、実行状況を監視したいときに使います。 + +* deferred:wait (msec) + * 引数： + * msec: 数値 + * 返値：deferredオブジェクト + * この関数が実行された時点から引数で指定されたミリ秒待って、後続のdeferredオブジェクトを実行します。 + * 後続のdeferredオブジェクトのコールバック関数の引数には、実際に経過した時間がミリ秒で渡ってきます。 + +* deferred:$ (forms...) + * 引数：1つ以上のdeferredフォーム + * 返値：一番最後のdeferredオブジェクト + * deferredオブジェクトのチェインを書きやすくするためのアナフォリックマクロです。 + * 一つ前のdeferredオブジェクトが「it」で渡ってきます。 + +#### ユーティリティ #### + +複数のdeferredを扱う関数です。 + +* deferred:loop (number-or-list callback) + * 引数： + * number-or-list: 1以上の整数もしくはリスト + * callback: 引数1つか0個の関数 + * 返値：deferredオブジェクト + * 引数の数値で指定された数だけループするようなdeferredオブジェクトを生成して返します。関数には0から始まるカウンタが渡ってきます。 + * 整数ではなくリストが渡ってきた場合は、mapcのようにループします。 + +* deferred:parallel (list-or-alist) + * 引数：以下のどちらか + * 1つ以上のdeferredオブジェクトか引数1つか0個の関数のリスト + * 1つ以上のシンボルとdeferredオブジェクトか引数1つか0個の関数によるconsセルのリスト（つまりalist） + * 返値：deferredオブジェクト + * 引数に与えられたdeferredオブジェクトを並列に実行し、結果を待ち合わせます。 + * 後続のdeferredには結果が順番の保持されたリストとして渡ります。 + * 引数にalistが渡した場合は、結果もalistで渡ります。この場合は順番は保持されません。 + * deferred処理の中でエラーが発生した場合は、結果のリストの中にエラーオブジェクトが入ります。 + +* deferred:earlier (list-or-alist) + * 引数：以下のどちらか + * 1つ以上のdeferredオブジェクトか引数1つか0個の関数のリスト + * 1つ以上のシンボルとdeferredオブジェクトか引数1つか0個の関数によるconsセルのリスト（つまりalist） + * 返値：deferredオブジェクト + * 引数に与えられたdeferredオブジェクトを並列に実行し、最初に帰ってきた結果を後続のdeferredに渡します。 + * 2番目以降の処理はキャンセルされ、結果が帰ってきても無視されます。 + * 引数にalistを渡した場合は、結果はconsセルで渡ります。 + * deferred処理の中でエラーが発生した場合は、結果が帰ってこなかったものとして扱われます。 + * すべての処理がエラーになった場合は、後続のdeferredにnilが渡ります。つまり、エラーバックで処理されません。 + +#### ラッパー #### + +元からある処理をdeferredでラップする関数です。 + +* deferred:call (function args...) + * 引数： + * function: 関数のシンボル + * args: 引数（可変長） + * 返値：deferredオブジェクト + * オリジナルのfuncallを非同期にした関数です + +* deferred:apply (function args) + * 引数： + * function: 関数のシンボル + * args: 引数（リスト） + * 返値：deferredオブジェクト + * オリジナルのapplyを非同期にした関数です + +* deferred:process (command args...) / deferred:process-shell (command args...) + * 引数： + * command: 外部実行コマンド + * args: コマンドの引数(可変長) + * 返値：deferredオブジェクト + * 外部コマンドを非同期で実行します。（start-process, start-process-shell-command のラッパー） + * 外部コマンドのstdoutの結果が文字列として後続のdeferredに渡ります。 + +* deferred:process-buffer (command args...) / deferred:process-shell-buffer (command args...) + * 引数： + * command: 外部実行コマンド + * args: コマンドの引数(可変長) + * 返値：deferredオブジェクト + * 外部コマンドを非同期で実行します。（start-process, start-process-shell-command のラッパー） + * 外部コマンドのstdoutの結果がバッファとして後続のdeferredに渡ります。 + * バッファの処分は後続のdeferredに任されます。 + +* deferred:wait-idle (msec) + * 引数： + * msec: 数値 + * 返値：deferredオブジェクト + * 引数で指定されたミリ秒間Emacsがアイドル状態だったときに、後続のdeferredオブジェクトを実行します。 + * 後続のdeferredオブジェクトのコールバック関数の引数には、この関数が呼ばれてから経過した時間がミリ秒で渡ってきます。 + +* deferred:url-retrieve (url [cbargs]) + * 引数： + * url: 取ってきたいURL + * cbargs: コールバック引数（オリジナル関数のもの。省略可。） + * 返値：deferredオブジェクト + * urlパッケージにある、オリジナルのurl-retrieveをdeferredでラップした関数です。 + * HTTPで取得した結果が、後続のdeferredにバッファで渡ります。 + * バッファの処分は後続のdeferredに任されます。 + +* （仮）deferred:url-get (url params) + * 引数： + * url: 取ってきたいURL + * params: パラメーターのalist + * 返値：deferredオブジェクト + * パラメーターを指定しやすくした関数です。仮実装ですので今後仕様が変わる可能性があります。 + +* （仮）deferred:url-post (url params) + * 引数： + * url: 取ってきたいURL + * params: パラメーターのalist + * 返値：deferredオブジェクト + * パラメーターを指定しやすくして、POSTでアクセスする関数です。仮実装ですので今後仕様が変わる可能性があります。 + +#### インスタンスメソッド #### + +プリミティブな操作を行う関数です。典型的でないdeferred処理を行いたい場合に、組み合わせて使います。 + +* deferred:new (callback) + * 引数：引数1つか0個の関数 + * 返値：deferredオブジェクト + * 引数の関数をコールバックとしてラップしたdeferredオブジェクトを生成して返します。 + * 実行キューに入れないため、deferred:callbackやdeferred:errorbackが呼ばれない限り実行されません。 + * 一時停止して他のイベントを待つような、deferredチェインを作りたいときに使います。 → deferred:wait のソースなどを参考。 + +* deferred:succeed ([value]) + * 引数：値（省略可） + * 返値：deferredオブジェクト + * 引数の値を使って、既にコールバックが呼ばれた状態のdeferredを返します。 + * 後続のdeferredは接続されたら直ちに（同期的に）実行されます。 + +* deferred:fail ([error]) + * 引数：値（省略可） + * 返値：deferredオブジェクト + * 引数の値を使って、既にエラーバックが呼ばれた状態のdeferredを返します。 + * 後続のdeferredは接続されたら直ちに（同期的に）実行されます。 + +* deferred:callback (d [value]) + * 引数： + * d: deferredオブジェクト + * value: 値（省略可） + * 返値：deferredオブジェクトか、結果値 + * 引数のdeferredオブジェクトを同期的に開始します。 + * ただし、同期的な実行は初回のみで、引数のdeferred以降のdeferredオブジェクトは非同期に実行されます。 + +* deferred:callback-post (d [value]) + * 引数： + * d: deferredオブジェクト + * value: 値（省略可） + * 返値：deferredオブジェクトか、結果値 + * 引数のdeferredオブジェクトを非同期に開始します。 + +* deferred:errorback (d [error]) + * 引数： + * d: deferredオブジェクト + * error: 値（省略可） + * 返値：deferredオブジェクトか、結果値 + * 引数のdeferredオブジェクトからエラーバックを同期的に開始します。 + +* deferred:errorback-post (d [error]) + * 引数： + * d: deferredオブジェクト + * error: 値（省略可） + * 返値：deferredオブジェクトか、結果値 + * 引数のdeferredオブジェクトからエラーバックを非同期に開始します。 + + +### ユーティリティマクロ ### + +いくつかの便利なマクロを用意しています。マクロですので、スコープや評価順序などに注意して予想外の動作に気をつけてください。 + +* deferred:try (d &key catch finally) + * 引数： + * d: deferredオブジェクト + * catch: [キーワード引数] dのタスクを実行中にエラーが起きたときに実行される関数。（マクロ展開によって deferred:error の引数に入る） + * finally: [キーワード引数] dのタスクが正常・エラーに関わらず終了したあとに実行する関数（マクロ展開によって deferred:watch の引数に入る） + * 返値：deferredオブジェクト + * 非同期処理で try-catch-finally のような処理を実現するマクロです。所詮非同期なので、メインのdeferredタスクの内容によっては、finallyタスクに処理が回ってこない可能性もあります。 + * deferred:error と deferred:watch を使って実装しています。 + +* deferred:timeout (msec timeout-form d) + * 引数： + * msec: 数値 + * timeout-form: キャンセル時に評価する sexp-form + * d: deferredオブジェクト + * 返値：deferredオブジェクト + * dのタスクを開始してmsecミリ秒経過した場合、dのタスクをキャンセルして、timeout-formの結果を後続のdeferredに渡します。 + * deferred:earlierとdeferred:waitを使って実装しています。 + +* deferred:process〜 + * deferred:processc (d command args...) + * deferred:process-bufferc (d command args...) + * deferred:process-shellc (d command args...) + * deferred:process-shell-bufferc (d command args...) + * 引数： + * d: deferredオブジェクト + * command: 外部実行コマンド + * args: コマンドの引数(可変長) + * 返値：deferredオブジェクト + * 外部コマンドを非同期で実行するdeferredオブジェクトをdに接続します。 + * deferred:nextc の lambda の中に元の関数を埋め込んで実装しています。 + +### 実行・接続 ### + +#### 処理開始について #### + +関数の中には処理を自動的に開始するものとしないものがあります。 + +以下の関数は、非同期実行用のキューにdeferredオブジェクトを登録します。つまり、自動的に実行を開始します。 + +* next +* wait +* loop +* parallel +* earlier +* call, apply +* process +* url-retrieve, url-get, url-post + +new は callback や errorback を呼ぶまで実行が開始されません。他のイベントを待って実行を開始するような用途で使います。 + +deferredオブジェクトは先にコールバックを実行しておいて、後で後続のdeferredオブジェクトをつなげることも出来ます。つまり、一番最後のdeferredオブジェクトは、続きのdeferredオブジェクトが接続されるまで結果を保持し続けます。succeed と fail は、そのような既に実行された状態の deferred を生成します。 + +#### ソースコード上のでの接続 #### + +deferredオブジェクトを$などを使ってソースコード上で連結することを、静的な接続と呼びます。 + +これはdeferredの基本的な使い方で、コールバック処理の書き方を変えたものだと言えます。 + +処理がコード上に並びますので読みやすく、流れも理解しやすいです。通常、このパターンを使います。 + +#### 実行時に接続 #### + +deferred処理の中でdeferredオブジェクトを返すと、静的に接続された（ソースコード上の）後続のdeferredオブジェクトの前に、そのdeferredを割り込ませます。 + +この動作により、ループや分岐などの高度な非同期処理を行うことができます。 + +## ポイント ## + +ここでは、いくつかの実装上のポイントを示します。 + +### レキシカルスコープ ### + +deferredの処理に値を持って行く場合、lexical-let などを用いてレキシカルスコープを使うと大変便利です。 + +特に、一連のdeferred処理の中で共通に使う値にレキシカルスコープを使うと、ローカル変数のようにアクセスすること出来るため、非同期処理のために値をグローバルに保持しておく必要が無くなります。 + +lexical-let 例: + +```el +(lexical-let ((a (point))) + (deferred:$ + (deferred:wait 1000) + (deferred:nextc it + (lambda (x) + (goto-char a) + (insert "here!"))))) +``` + +逆に、lexical-letでレキシカルスコープにバインドしていないシンボルを参照しようとして、エラーになることがよくあります。 + +### カレント状態 ### + +save-execursion や with-current-buffer など、S式の範囲で状態を保持する関数がありますが、deferred関数を囲っていても非同期で処理される時点では無効になっています。 + +ダメな例: + +```el +(with-current-buffer (get-buffer "*Message*") + (deferred:$ + (deferred:wait 1000) + (deferred:nextc it + (lambda (x) + (insert "Time: %s " x) ; ここは *Message* バッファとは限らない！ + )))) +``` + +このような場合は、レキシカルスコープなどでdeferredの中にバッファオブジェクトを持って行き、その中でバッファを切り替える必要があります。 + +改善例: + +```el +(lexical-let ((buf (get-buffer "*Message*"))) + (deferred:$ + (deferred:wait 1000) + (deferred:nextc it + (lambda (x) + (with-current-buffer buf ; 非同期処理の中で設定する + (insert "Time: %s " x)))))) +``` + +### lambdaの返り値に気を使う ### + +先に述べたとおり、deferredの処理の中でdeferredオブジェクトを返すと、動的な接続によりdeferred処理が割り込まれます。しかしながら、意図せずdeferredオブジェクトを返してしまい、実行順序がおかしくなり、バグに繋がるケースがあります。 + +そのため、deferredのコールバックで返す値には気をつける必要があります。特に値を返さない場合は、予防として明示的にnilを返すようにするといいと思います。 + +### デバッグ ### + +通常の処理に比べて、非同期の処理はデバッグが難しいことが多いです。デバッガが使える場面も多いですが、デバッガで停止中に他の非同期処理が行われたりすることがあるため、正しくデバッグできないこともあります。その場合は、message文をちりばめるとか、独自のログバッファに出力するなどしてデバッグすることが確実だと思います。 + +意図せず無限ループに陥って、非同期処理が延々と走り続けてしまうことがあります。その場合は、 deferred:clear-queue 関数を呼ぶ（M-xからも呼べます）ことで、実行キューを空にして止めることが出来ます。 + +非同期のタスクで発生したエラーは、エラーバックで拾わないと最終的にはmessageに表示されます。deferredの実装内部は condition-case で囲っていますので、デバッガでエラーを拾いたい場合は toggle-debug-on-error でデバッガを有効にすると同時に、 deferred:debug-on-signal を t に設定して発生したエラー取得するようにしてください。 + +deferred:sync! 関数を使うことによって、deferred タスクを待ち合わせて同期的にすることができます。ただし、待ち合わせは完全ではないため、テストやデバッグ目的にのみ使うようにして、実アプリでは使わないようにしてください。 + +### マクロ ### + +deferred.elを使うと、nextcやlambdaをたくさん書くことになると思います。これらをマクロでラップすることで短く書くことが可能になります。deferred.elのテストコードのtest-deferred.elでは、マクロを使ってとにかく短く書いています。 + +一方、マクロでlambdaを隠蔽することで、フォームを実行した値を渡したいのか、あるいは非同期に実行される関数が引数なのか、分かりづらくなるおそれがあります。そういった理由からdeferred.elでは積極的に便利なマクロを提供していません。マクロで短く書く場合には、実行されるタイミングに気をつける必要があります。 + +### deferred入門 ### + +deferredによってどのようなことが可能になるかなどについては、JavaScriptの例ではありますが、以下のドキュメントが大変参考になると思います。 + +* [JSDeferred紹介](http://cho45.stfuawsc.com/jsdeferred/doc/intro.html "JSDeferred紹介") +* [特集：JSDeferredで，面倒な非同期処理とサヨナラ｜gihyo.jp … 技術評論社](http://gihyo.jp/dev/feature/01/jsdeferred "特集：JSDeferredで，面倒な非同期処理とサヨナラ｜gihyo.jp … 技術評論社") + + +* * * * * + +(C) 2010-2016 SAKURAI Masashi All rights reserved. +m.sakurai at kiwanami.net diff --git a/README.markdown b/README.markdown new file mode 100644 index 0000000..8b189ed --- /dev/null +++ b/README.markdown @@ -0,0 +1,721 @@ +# deferred.el # + +[![Build Status](https://travis-ci.org/kiwanami/emacs-deferred.svg)](https://travis-ci.org/kiwanami/emacs-deferred) +[![Coverage Status](https://coveralls.io/repos/kiwanami/emacs-deferred/badge.svg)](https://coveralls.io/r/kiwanami/emacs-deferred) +[![MELPA](http://melpa.org/packages/deferred-badge.svg)](http://melpa.org/#/deferred) +[![MELPA stable](http://stable.melpa.org/packages/deferred-badge.svg)](http://stable.melpa.org/#/deferred) +[![Tag Version](https://img.shields.io/github/tag/kiwanami/emacs-deferred.svg)](https://github.com/kiwanami/emacs-deferred/tags) +[![License](http://img.shields.io/:license-gpl3-blue.svg)](http://www.gnu.org/licenses/gpl-3.0.html) + +`deferred.el` provides facilities to manage asynchronous tasks. + +The API and implementations were translated from +[JSDeferred](https://github.com/cho45/jsdeferred "JSDeferred") (by cho45) and +[Mochikit.Async](http://mochikit.com/doc/html/MochiKit/Async.html +"Mochikit.Async") (by Bob Ippolito) in JavaScript. + +*(note the README for `concurrent` is [here in the same repo](./README-concurrent.markdown))* + +## Installation ## + +You can install deferred.el from [MELPA](http://melpa.org) by package.el. + +## Sample codes ## + +You can find following sample codes in `deferred-sample.el`. +Executing `eval-last-sexp` (C-x C-e), you can try those codes. + +### Basic usage ### + +This is a basic deferred chain. This code puts some outputs into +message buffer, and then require a number from minibuffer. + +Chain: + +```el +(deferred:$ + (deferred:next + (lambda () (message "deferred start"))) + (deferred:nextc it + (lambda () + (message "chain 1") + 1)) + (deferred:nextc it + (lambda (x) + (message "chain 2 : %s" x))) + (deferred:nextc it + (lambda () + (read-minibuffer "Input a number: "))) + (deferred:nextc it + (lambda (x) + (message "Got the number : %i" x))) + (deferred:error it + (lambda (err) + (message "Wrong input : %s" err)))) +``` + +* This s-exp returns immediately. + * Asynchronous tasks start subsequently. +* The macro `deferred:$` chains deferred objects. + * The anaphoric variable `it` holds a deferred object in the previous line. +* The next deferred task receives the value that is returned by the previous deferred one. +* Inputting a wrong value, such as alphabets, this s-exp raises an error. The error is caught by the errorback function defined by `deferred:error`. + +### Timer ### + +After evaluating this s-exp and waiting for 1 second, a message is shown in the minibuffer. + +Timer: + +```el +(deferred:$ + (deferred:wait 1000) ; 1000msec + (deferred:nextc it + (lambda (x) + (message "Timer sample! : %s msec" x)))) +``` + +* The next deferred task subsequent to deferred:wait receives the actual elapse time in millisecond. + +### Commands and Sub-process ### + +This s-exp inserts the result that is performed by the command `ls -la`. (This s-exp may not run in windows. Try `dir` command.) + +Command process: + +```el +(deferred:$ + (deferred:process "ls" "-la") + (deferred:nextc it + (lambda (x) (insert x)))) +``` + +* This s-exp hardly blocks Emacs because of asynchronous mechanisms. + + +### HTTP GET : Text ### + +This s-exp inserts a text from http://www.gnu.org asynchronously. (You can clear the result with undo command.) + +HTTP GET: + +```el +(require 'url) + +(deferred:$ + (deferred:url-retrieve "http://www.gnu.org") + (deferred:nextc it + (lambda (buf) + (insert (with-current-buffer buf (buffer-string))) + (kill-buffer buf)))) +``` + +### HTTP Get : Image ### + +This s-exp inserts an image from google asynchronously. + +Get an image: + +```el +(deferred:$ + (deferred:url-retrieve "http://www.google.co.jp/intl/en_com/images/srpr/logo1w.png") + (deferred:nextc it + (lambda (buf) + (insert-image + (create-image + (let ((data (with-current-buffer buf (buffer-string)))) + (substring data (+ (string-match "\n\n" data) 2))) + 'png t)) + (kill-buffer buf)))) +``` + +### Parallel ### + +This s-exp retrieves two images from google concurrently and wait for the both results. Then, the file sizes of the images are inserted the current buffer. + +Parallel deferred: + +```el +(deferred:$ + (deferred:parallel + (lambda () + (deferred:url-retrieve "http://www.google.co.jp/intl/en_com/images/srpr/logo1w.png")) + (lambda () + (deferred:url-retrieve "http://www.google.co.jp/images/srpr/nav_logo14.png"))) + (deferred:nextc it + (lambda (buffers) + (loop for i in buffers + do + (insert + (format + "size: %s\n" + (with-current-buffer i (length (buffer-string))))) + (kill-buffer i))))) +``` + +* The function `deferred:parallel` runs asynchronous tasks concurrently. +* The function wait for all results, regardless normal or abnormal. Then, the subsequent tasks are executed. +* The next task receives a list of the results. + * The order of the results is corresponding to one of the argument. + * Giving an alist of tasks as the argument, the results alist is returned. + +### Deferred Combination : try-catch-finally ### + +This s-exp executes following tasks: +* Getting an image by wget command, +* Resizing the image by convert command in ImageMagick, +* Insert the re-sized image into the current buffer. +You can construct the control structure of deferred tasks, like try-catch-finally in Java. + +Get an image by wget and resize by ImageMagick: + +```el +(deferred:$ + + ;; try + (deferred:$ + (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png") + (deferred:nextc it + (lambda () (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg"))) + (deferred:nextc it + (lambda () + (clear-image-cache) + (insert-image (create-image (expand-file-name "b.jpg") 'jpeg nil))))) + + ;; catch + (deferred:error it ; + (lambda (err) + (insert "Can not get a image! : " err))) + + ;; finally + (deferred:nextc it + (lambda () + (deferred:parallel + (lambda () (delete-file "a.jpg")) + (lambda () (delete-file "b.jpg"))))) + (deferred:nextc it + (lambda (x) (message ">> %s" x)))) +``` + +* In this case, the deferred tasks are statically connected. + +Here is an another sample code for try-catch-finally blocks. This is simpler than above code because of the `deferred:try' macro. (Note: They bring the same results practically, but are not perfectly identical. The `finally` task may not be called because of asynchrony.) + +Try-catch-finally: + +```el +(deferred:$ + (deferred:try + (deferred:$ + (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png") + (deferred:nextc it + (lambda () (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg"))) + (deferred:nextc it + (lambda () + (clear-image-cache) + (insert-image (create-image (expand-file-name "b.jpg") `jpeg nil))))) + :catch + (lambda (err) (insert "Can not get a image! : " err)) + :finally + (lambda () + (delete-file "a.jpg") + (delete-file "b.jpg"))) + (deferred:nextc it + (lambda (x) (message ">> %s" x)))) +``` + +### Timeout ### + +Although a long time command is executed (3 second sleeping), the task is rejected by timeout for 1 second. + +The function `deferred:earlier` also runs asynchronous tasks concurrently, however, the next deferred task receives the first result. The other results and tasks will be rejected (canceled or ignored). + +Timeout Process: + +```el +(deferred:$ + (deferred:earlier + (deferred:process "sh" "-c" "sleep 3 | echo 'hello!'") + (deferred:$ + (deferred:wait 1000) ; timeout msec + (deferred:nextc it (lambda () "canceled!")))) + (deferred:nextc it + (lambda (x) (insert x)))) +``` + +* Changing longer timeout for `deferred:wait`, the next task receives a result of the command. +* When a task finishes abnormally, the task is ignored. + * When all tasks finishes abnormally, the next task receives nil. +* The functions `deferred:parallel` and `deferred:earlier` may be corresponding to `and` and `or`, respectively. + +Here is an another sample code for timeout, employing `deferred:timeout` macro. + +Timeout macro: + +```el +(deferred:$ + (deferred:timeout + 1000 "canceled!" + (deferred:process "sh" "-c" "sleep 3 | echo 'hello!'")) + (deferred:nextc it + (lambda (x) (insert x)))) +``` + +Note that the `deferred:timeout` and `deferred:earlier` just rejects the task result and does not stop the running task chains. Please see the document for `deferred:cancel`. + +### Loop and Animation ### + +This s-exp plays an animation at the cursor position for few seconds. Then, you can move cursor freely, because the animation does not block Emacs. + +Returning a deferred object in the deferred tasks, the returned task is executed before the next deferred one that is statically connected on the source code. (In this case, the interrupt task is dynamically connected.) + +Employing a recursive structure of deferred tasks, you can construct a deferred loop. +It may seem the multi-thread in Emacs Lisp. + +Loop and animation: + +```el +(lexical-let ((count 0) (anm "-/|\\-") + (end 50) (pos (point)) + (wait-time 50)) + (deferred:$ + (deferred:next + (lambda (x) (message "Animation started."))) + + (deferred:nextc it + (deferred:lambda (x) + (save-excursion + (when (< 0 count) + (goto-char pos) (delete-char 1)) + (insert (char-to-string + (aref anm (% count (length anm)))))) + (if (> end (incf count)) ; return nil to stop this loop + (deferred:nextc (deferred:wait wait-time) self)))) ; return the deferred + + (deferred:nextc it + (lambda (x) + (save-excursion + (goto-char pos) (delete-char 1)) + (message "Animation finished."))))) +``` + +* `deferred:lambda` is an anaphoric macro in which `self` refers itself. It is convenient to construct a recursive structure. + +### Wrapping asynchronous function ### + +Let's say you have an asynchronous function which takes a callback. For example, dbus.el, xml-rpc.el and websocket.el has such kind of asynchronous APIs. To use such libraries with deferred.el, you can make an unregistered deferred object using `deferred:new` and then start the deferred callback queue using `deferred:callback-post` in the callback given to the asynchronous function. If the asynchronous function supports "errorback", you can use `deferred:errorback-post` to pass the error information to the following callback queue. + +In the following example, `run-at-time` is used as an example for the asynchronous function. Deferred.el already has `deferred:wait` for this purpose so that you don't need the following code if you want to use `run-at-time`. + +```el +(deferred:$ + (deferred:next + (lambda () + (message "1") + 1)) + (deferred:nextc it + (lambda (x) + (lexical-let ((d (deferred:new #'identity))) + (run-at-time 0 nil (lambda (x) + ;; Start the following callback queue now. + (deferred:callback-post d x)) + x) + ;; Return the unregistered (not yet started) callback + ;; queue, so that the following queue will wait until it + ;; is started. + d))) + ;; You can connect deferred callback queues + (deferred:nextc it + (lambda (x) + (message "%s" (1+ x))))) +``` + +## API ## + +### Functions ### + +#### Basic functions #### + +* deferred:next (callback) + * Arguments + * callback: a function with zero or one argument + * Return + * a deferred object + * Return a deferred object that wrap the given callback function. Then, put the deferred object into the execution queue to run asynchronously. + * Namely, run the given function asynchronously. + + +* deferred:nextc (d callback) + * Arguments + * d: a deferred object + * callback: a function with zero or one argument + * Return + * a deferred object + * Return a deferred object that wrap the given callback function. Then, connect the created deferred object with the given deferred object. + * Namely, add the given function to the previous deferred object. + +* deferred:error (d errorback) + * Arguments + * d: a deferred object + * errorback: a function with zero or one argument + * Return + * a deferred object + * Return a deferred object that wrap the given function as errorback. Then, connect the created deferred object with the given deferred object. + * Namely, the given function catches the error occurred in the previous task. + * If this function does not throw an error, the subsequent callback functions are executed. + +* deferred:cancel (d) + * Arguments + * d: a deferred object + * Return + * the given deferred object (invalidated) + * Invalidate the given deferred object. + * Because this function modifies the deferred object, one can not used the given deferred instance again. + * This function just cancels the given deferred instance, not the whole deferred chain. In the current deferred implementation, a message of cancellation can not propagate to chained deferred objects because the chain is built by the singly linked list. If the deferred chains may be canceled on your code, you should care the side-effect tasks. + +* deferred:watch (d callback) + * Arguments + * d: deferred object + * callback: a function with zero or one argument + * Return + * a deferred object + * Create a deferred object with watch task and connect it to the given deferred object. + * The watch task CALLBACK can not affect deferred chains with return values. + * This function is used in following purposes, simulation of try-finally block in asynchronous tasks, monitoring of progress of deferred tasks. + +* deferred:wait (msec) + * Arguments + * msec: a number (millisecond) + * Return + * a deferred object + * Return a deferred object that will be called after the specified millisecond. + * The subsequent deferred task receives the actual elapse time in millisecond. + +* deferred:$ + * Arguments / more than one deferred forms + * Return / the last deferred object + * An anaphoric macro chains deferred objects. + * The anaphoric variable `it` holds a deferred object in the previous line. + +#### Utility functions #### + +* deferred:loop (number-or-list callback) + * Arguments + * number-or-list: an integer or a list + * callback: a function with zero or one argument + * Return + * a deferred object + * Return a deferred object that iterates the function for the specified times. + * The function receives the count number that begins zero. + * If a list is given, not a number, the function visits each elements in the list like `mapc`. + +* deferred:parallel (list-or-alist) + * Arguments + * list-or-alist: + * more than one deferred objects or a list of functions + * an alist consist of cons cells with a symbol and a deferred object or a function + * Return + * a deferred object + * Return a deferred object that executes given functions in parallel and wait for all callback values. + * The subsequent deferred task receives a list of the results. The order of the results is corresponding to one of the argument. + * Giving an alist of tasks as the argument, the results alist is returned. + * If the parallel task throws an error, the error object is passed as a result. + +* deferred:earlier (list-or-alist) + * Arguments + * list-or-alist: + * more than one deferred objects or a list of functions + * an alist consist of cons cells with a symbol and a deferred object or a function + * Return + * a deferred object + * Return a deferred object that executes given functions in parallel and wait for the first callback value. + * The other tasks are rejected. (See the document for `deferred:cancel`) + * Giving an alist of tasks as the argument, a cons cell is returned as a result. + * When a task finishes abnormally, the task is ignored. + * When all tasks finishes abnormally, the next task receives nil. That is, no errorback function is called. + +#### Wrapper functions #### + +* deferred:call (function args...) + * Arguments + * function: a function + * args: arguments (variable length) + * Return + * a deferred object + * a wrapper of the function `funcall` + +* deferred:apply (function args) + * Arguments + * function: a function + * args: a list of arguments + * Return + * a deferred object + * a wrapper of the function `apply` + +* deferred:process (command args...) / deferred:process-shell (command args...) + * Arguments + * command: command to execute + * args: command arguments (variable length) + * Return + * a deferred object + * Execute a command asynchronously. These functions are wrappers of `start-process` and `start-process-shell-command`. + * The subsequent deferred task receives the stdout from the command as a string. + +* deferred:process-buffer (command args...) / deferred:process-shell-buffer (command args...) + * Arguments + * command: command to execute + * args: command arguments (variable length) + * Return + * a deferred object + * Execute a command asynchronously. These functions are wrappers of `start-process` and `start-process-shell-command`. + * The subsequent deferred task receives the stdout from the command as a buffer. + * The following tasks are responsible to kill the buffer. + +* deferred:wait-idle (msec) + * Arguments + * msec: a number (millisecond) + * Return + * a deferred object + * Return a deferred object that will be called when Emacs has been idle for the specified millisecond. + * The subsequent deferred task receives the elapse time in millisecond. + +* deferred:url-retrieve (url [cbargs]) + * Arguments + * url: URL to get + * cbargs: callback argument (optional) + * Return + * a deferred object + * A wrapper function of `url-retrieve` in the `url` package. + * The subsequent deferred task receives the content as a buffer. + * The following tasks are responsible to kill the buffer. + +* [experimental] deferred:url-get (url [params]) + * Arguments + * url: URL to get + * params: alist of parameters + * Return + * a deferred object + +* [experimental] deferred:url-post (url [params]) + * Arguments + * url: URL to get + * params: alist of parameters + * Return + * a deferred object + +#### Primitive functions #### + +* deferred:new ([callback]) + * Arguments + * callback: a function with zero or one argument (optional) + * Return + * a deferred object + * Create a deferred object + * The created deferred object is never called until someone call the function `deferred:callback` or `deferred:errorback`. + * Using this object, a deferred chain can pause to wait for other events. (See the source for `deferred:wait`.) + +* deferred:succeed ([value]) + * Arguments + * value: a value (optional) + * Return + * a deferred object + * Create a deferred object that has been called the callback function. + * When a deferred task is connected, the subsequent task will be executed immediately (synchronously). + +* deferred:fail ([error]) + * Arguments + * error: an error value (optional) + * Return + * a deferred object + * Create a deferred object that has been called the errorback function. + * When a deferred task is connected, the subsequent task will be executed immediately (synchronously). + +* deferred:callback (d [value]) + * Arguments + * d: a deferred object + * value: a value (optional) + * Return + * a deferred object or a result value + * Start executing the deferred tasks. The first task is executed synchronously. + +* deferred:callback-post (d [value]) + * Arguments + * d: a deferred object + * value: a value (optional) + * Return + * a deferred object or a result value + * Start executing the deferred tasks. The first task is executed asynchronously. + +* deferred:errorback (d [error]) + * Arguments + * d: a deferred object + * error: an error value (optional) + * Return + * a deferred object or a result value + * Start executing the deferred tasks from errorback. The first task is executed synchronously. + +* deferred:errorback-post (d [error]) + * Arguments + * d: a deferred object + * error: an error value (optional) + * Return + * a deferred object or a result value + * Start executing the deferred tasks from errorback. The first task is executed asynchronously. + +### Utility Macros ### + +* deferred:try (d &key catch finally) + * Arguments + * d: deferred object + * catch: [keyword argument] A function that is called when an error is occurred during tasks `d`. (This function is expanded as an argument of `deferred:error`.) + * finally: [keyword argument] A function that is called when tasks `d` finishes whether in success or failure. (This function is expanded as an argument of deferred:watch.) + * Return + * a deferred object + * Try-catch-finally macro. This macro simulates the try-catch-finally block asynchronously. + * Because of asynchrony, this macro does not ensure that the `finally` task should be called. + * This macro is implemented by `deferred:error` and `deferred:watch`. + +* deferred:timeout (msec timeout-form d) + * Arguments + * msec: a number + * timeout-form: sexp-form + * d: a deferred object + * Return + * a deferred object + * Time out macro on a deferred task `d`. + * If the deferred task `d` does not complete within `timeout-msec`, this macro rejects the deferred task and return the `timeout-form`. (See the document for `deferred:cancel`) + * This macro is implemented by `deferred:earlier` and `deferred:wait`. + +* deferred:process... + * deferred:processc (d command args...) + * deferred:process-bufferc (d command args...) + * deferred:process-shellc (d command args...) + * deferred:process-shell-bufferc (d command args...) + * Arguments + * d: a deferred object + * command: command to execute + * args: command arguments (variable length) + * Return + * a deferred object + * This macro wraps the deferred:process function in deferred:nextc and connect the given deferred task. + +### Execution and Connection ### + +#### Firing #### + +Some deferred functions can fire a deferred chain implicitly. Following functions register a deferred object with the execution queue to run asynchronously. + +* next +* wait +* loop +* parallel +* earlier +* call, apply +* process +* url-retrieve, url-get, url-post + + +The deferred tasks those are created by `deferred:new` are never called. Using this object, a deferred chain can pause to wait for other events. (See the source for `deferred:wait`.) + + +One can fire the chain before connecting. That is, deferred objects wait for connecting the subsequent task holding the result value. The functions `deferred:succeed` and `deferred:fail` create those waiting objects. + +#### Static connection #### + +The `static connection (statically connected)` is a connection between deferred tasks on the source code. +This is a basic usage for the deferred chain. + +The static connection is almost equivalent to ordinary callback notation as an argument in the function declarations. The deferred notation is easy to read and write better than the callback one, because the sequence of asynchronous tasks can be written by the deferred notation straightforward. + +#### Dynamic Connection #### + +Returning a deferred object in the deferred tasks, the returned task is executed before the next deferred one that is statically connected on the source code. This is the `dynamic connection (dynamically connected)`. + +Employing a recursive structure of deferred tasks, you can construct higher level control structures, such as loop. + +## Discussion ## + +Some discussions of writing deferred codes. + +### Using lexical scope ### + +Using the lexical scope macro, such as `lexical-let`, the deferred tasks defined by lambdas can access local variables. + +`lexical-let` Ex.: + +```el +(lexical-let ((a (point))) + (deferred:$ + (deferred:wait 1000) + (deferred:nextc it + (lambda (x) + (goto-char a) + (insert "here!"))))) +``` + +If you write a code of deferred tasks without lexical scope macros, you should be careful with the scopes of each variables. + +### Excursion (Current status) ### + +The `excursion` functions those hold the current status with the s-exp form, such as `save-execursion` or `with-current-buffer`, are not valid in the deferred tasks, because of execution asynchronously. + +Wrong Ex.: + +```el +(with-current-buffer (get-buffer "*Message*") + (deferred:$ + (deferred:wait 1000) + (deferred:nextc it + (lambda (x) + (insert "Time: %s " x) ; `insert` may not be in the *Message* buffer! + )))) +``` + +In this case, using lexical scope macros to access the buffer variable, you can change the buffer in the deferred task. + +Corrected: + +```el +(lexical-let ((buf (get-buffer "*Message*"))) + (deferred:$ + (deferred:wait 1000) + (deferred:nextc it + (lambda (x) + (with-current-buffer buf ; Set buffer in the asynchronous task. + (insert "Time: %s " x)))))) +``` + + +### Be aware of return values ### + +However the dynamic connection is a powerful feature, sometimes it causes bugs of the wrong execution order, because of returning not intended deferred objects. + +Then, you should watch the return values of the deferred tasks not to cause an unexpected dynamic connection. + +### Debugging ### + +The debugging of asynchronous tasks is difficult. Of course, you can use debugger for deferred tasks, but asynchronous tasks cause some troubles, such as interruptions of your debugging and timing gap of simultaneous deferred tasks. Therefore, logging is a safe debugging to observe the tasks correctly, for example, using the `message` function and making custom application log buffer. + +If deferred tasks fall into an infinite loop unexpectedly (but Emacs may not freeze), calling the command `deferred:clear-queue`, you can stop the deferred tasks immediately. + +If the errors occurred in deferred tasks are caught by no errorback functions, finally the deferred framework catches it and reports to the message buffer. Because the implementation of the framework uses a `condition-case` form, the debugger can not catch the signals normally. If you want to debug the errors in the deferred tasks with the debug-on-error mechanism, set the variable `deferred:debug-on-signal` non-nil. + +Wrapping a deferred task in the function `deferred:sync!`, you can wait for the result of the task synchronously. However, the wrapper function should be used for test or debug purpose, because the synchronous waiting is not exact. + +### Using macros ### + +Writing deferred tasks with `deferred.el`, you may write a lot of `deferred:nextc` and `lambda` to define tasks. Defining a macro, you may write codes shortly. The test code `test-deferred.el` uses many macros to shorten test codes. + +On the other hand, using macros to hide `lambda`, it is difficult to realize when the deferred codes are evaluated. That is why `deferred.el` does not provide lot of convenient macros. If you use macros, be careful evaluation timing of deferred forms. + +### Introduction for deferred ### + +Following documents are good introduction to deferred. + +* [Introduction to JSDeferred](http://cho45.stfuawsc.com/jsdeferred/doc/intro.en.html "Introduction to JSDeferred") +* [JSDeferred site](http://cho45.stfuawsc.com/jsdeferred/ "JSDeferred site") + +* * * * * + +(C) 2010-2016 SAKURAI Masashi All rights reserved. +m.sakurai at kiwanami.net diff --git a/concurrent.el b/concurrent.el new file mode 100644 index 0000000..767fdf6 --- /dev/null +++ b/concurrent.el @@ -0,0 +1,506 @@ +;;; concurrent.el --- Concurrent utility functions for emacs lisp + +;; Copyright (C) 2010-2016 SAKURAI Masashi + +;; Author: SAKURAI Masashi +;; Version: 0.4.0 +;; Keywords: deferred, async, concurrent +;; Package-Requires: ((deferred "0.4.0")) +;; URL: https://github.com/kiwanami/emacs-deferred/blob/master/README-concurrent.markdown + +;; 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 . + +;;; Commentary: + +;; 'concurrent.el' is a higher level library for concurrent tasks +;; based on 'deferred.el'. This library has following features: +;; +;; - Generator +;; - Green thread +;; - Semaphore +;; - Dataflow +;; - Signal/Channel + +(require 'cl) + +(require 'deferred) + +(defvar cc:version nil "version number") +(setq cc:version "0.3") + +;;; Code: + + + +(defmacro cc:aif (test-form then-form &rest else-forms) + (declare (debug (form form &rest form))) + `(let ((it ,test-form)) + (if it ,then-form ,@else-forms))) +(put 'cc:aif 'lisp-indent-function 2) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Generator + +(defun cc:generator-replace-yield (tree) + "[internal] Replace `yield' symbols to calling a function in TREE." + (let (ret) + (loop for i in tree + do (cond + ((eq i 'yield) + (push 'funcall ret) + (push i ret)) + ((listp i) + (push (cc:generator-replace-yield i) ret)) + (t + (push i ret)))) + (nreverse ret))) + +(defun cc:generator-line (chain line) + "[internal] Return a macro expansion to execute the sexp LINE +asynchronously." + (cond + ;; function object + ((functionp line) + `(setq ,chain (deferred:nextc ,chain ,line))) + ;; while loop form + ((eq 'while (car line)) + (let ((condition (cadr line)) + (body (cddr line))) + `(setq ,chain + (deferred:nextc ,chain + (deferred:lambda (x) + (if ,condition + (deferred:nextc + (progn + ,@(cc:generator-replace-yield body)) self))))))) + ;; statement + (t + `(setq ,chain + (deferred:nextc ,chain + (deferred:lambda (x) ,(cc:generator-replace-yield line))))))) + +(defmacro cc:generator (callback &rest body) + "Create a generator object. If BODY has `yield' symbols, it +means calling callback function CALLBACK." + (let ((chain (gensym)) + (cc (gensym)) + (waiter (gensym))) + `(lexical-let* + (,chain + (,cc ,callback) + (,waiter (deferred:new)) + (yield (lambda (x) (funcall ,cc x) ,waiter))) + (setq ,chain ,waiter) + ,@(loop for i in body + collect + (cc:generator-line chain i)) + (lambda () (deferred:callback ,waiter))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Thread + +(defun cc:thread-line (wait-time chain line) + "[internal] Return a macro expansion to execute the sexp LINE asynchronously. +WAIT-TIME is an interval time between tasks. +CHAIN is the previous deferred task." + (cond + ;; function object + ((functionp line) + `(setq ,chain (deferred:nextc ,chain ,line))) + ;; while loop form + ((eq 'while (car line)) + (let ((condition (cadr line)) + (body (cddr line)) + (retsym (gensym))) + `(setq ,chain + (deferred:nextc ,chain + (deferred:lambda (x) + (if ,condition + (deferred:nextc + (let ((,retsym (progn ,@body))) + (if (deferred-p ,retsym) ,retsym + (deferred:wait ,wait-time))) + self))))))) + ;; statement + (t + `(setq ,chain + (deferred:nextc ,chain + (lambda (x) ,line)))))) + +(defmacro cc:thread (wait-time-msec &rest body) + "Return a thread object." + (let ((chain (gensym)) + (dstart (gensym))) + `(lexical-let* + (,chain + (,dstart (deferred:new))) + (setq ,chain ,dstart) + ,@(loop for i in body + collect + (cc:thread-line wait-time-msec chain i)) + (deferred:callback ,dstart)))) +(put 'cc:thread 'lisp-indent-function 1) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Semaphore + +(defstruct cc:semaphore max-permits permits waiting-deferreds) + +(defun cc:semaphore-create(permits-num) + "Return a semaphore object with PERMITS-NUM permissions." + (make-cc:semaphore :max-permits permits-num :permits permits-num)) + +(defun cc:semaphore-acquire(semaphore) + "Acquire an execution permission and return deferred object to chain. +If this semaphore object has permissions, the subsequent deferred +task is executed immediately. If this semaphore object has no +permissions, the subsequent deferred task is blocked. After the +permission is returned, the task is executed." + (cond + ((< 0 (cc:semaphore-permits semaphore)) + (decf (cc:semaphore-permits semaphore)) + (deferred:succeed)) + (t + (let ((d (deferred:new))) + (push d (cc:semaphore-waiting-deferreds semaphore)) + d)))) + +(defun cc:semaphore-release(semaphore) + "Release an execution permission. The programmer is responsible to return the permissions." + (when (<= (cc:semaphore-max-permits semaphore) + (cc:semaphore-permits semaphore)) + (error "Too many calling semaphore-release. [max:%s <= permits:%s]" + (cc:semaphore-max-permits semaphore) + (cc:semaphore-permits semaphore))) + (let ((waiting-deferreds + (cc:semaphore-waiting-deferreds semaphore))) + (cond + (waiting-deferreds + (let* ((d (car (last waiting-deferreds)))) + (setf (cc:semaphore-waiting-deferreds semaphore) + (nbutlast waiting-deferreds)) + (deferred:callback-post d))) + (t + (incf (cc:semaphore-permits semaphore))))) + semaphore) + +(defun cc:semaphore-with (semaphore body-func &optional error-func) + "Execute the task BODY-FUNC asynchronously with the semaphore block." + (lexical-let ((semaphore semaphore)) + (deferred:try + (deferred:nextc (cc:semaphore-acquire semaphore) body-func) + :catch + error-func + :finally + (lambda (_x) (cc:semaphore-release semaphore))))) +(put 'cc:semaphore-with 'lisp-indent-function 1) + +(defun cc:semaphore-release-all (semaphore) + "Release all permissions for resetting the semaphore object. +If the semaphore object has some blocked tasks, this function +return a list of the tasks and clear the list of the blocked +tasks in the semaphore object." + (setf (cc:semaphore-permits semaphore) + (cc:semaphore-max-permits semaphore)) + (let ((ds (cc:semaphore-waiting-deferreds semaphore))) + (when ds + (setf (cc:semaphore-waiting-deferreds semaphore) nil)) + ds)) + +(defun cc:semaphore-interrupt-all (semaphore) + "Clear the list of the blocked tasks in the semaphore and return a deferred object to chain. +This function is used for the interruption cases." + (when (cc:semaphore-waiting-deferreds semaphore) + (setf (cc:semaphore-waiting-deferreds semaphore) nil) + (setf (cc:semaphore-permits semaphore) 0)) + (cc:semaphore-acquire semaphore)) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Signal / Channel + +(defun cc:signal-channel (&optional name parent-channel) + "Create a channel. +NAME is a channel name for debug. +PARENT-CHANNEL is an upstream channel. The observers of this channel can receive the upstream signals. +In the case of using the function `cc:signal-send', the observers of the upstream channel can not receive the signals of this channel. The function `cc:signal-send-global' can send a signal to the upstream channels from the downstream channels." + (lexical-let + ((ch (cons + (or name (format "signal%s" (deferred:uid))) ; name for debug + (cons + parent-channel ; parent-channel + nil)))) ; observers + (when parent-channel + (cc:signal-connect + parent-channel + t (lambda (event) + (destructuring-bind + (event-name event-args) event + (apply 'cc:signal-send + ch event-name event-args))))) + ch)) + +(defmacro cc:signal-name (ch) + "[internal] Return signal name." + `(car ,ch)) + +(defmacro cc:signal-parent-channel (ch) + "[internal] Return parent channel object." + `(cadr ,ch)) + +(defmacro cc:signal-observers (ch) + "[internal] Return observers." + `(cddr ,ch)) + +(defun cc:signal-connect (channel event-sym &optional callback) + "Append an observer for EVENT-SYM of CHANNEL and return a deferred object. +If EVENT-SYM is `t', the observer receives all signals of the channel. +If CALLBACK function is given, the deferred object executes the +CALLBACK function asynchronously. One can connect subsequent +tasks to the returned deferred object." + (let ((d (if callback + (deferred:new callback) + (deferred:new)))) + (push (cons event-sym d) + (cc:signal-observers channel)) + d)) + +(defun cc:signal-send (channel event-sym &rest args) + "Send a signal to CHANNEL. If ARGS values are given, observers can get the values by following code: (lambda (event) (destructuring-bind (event-sym (args)) event ... )). " + (let ((observers (cc:signal-observers channel)) + (event (list event-sym args))) + (loop for i in observers + for name = (car i) + for d = (cdr i) + if (or (eq event-sym name) (eq t name)) + do (deferred:callback-post d event)))) + +(defun cc:signal-send-global (channel event-sym &rest args) + "Send a signal to the most upstream channel. " + (cc:aif (cc:signal-parent-channel channel) + (apply 'cc:signal-send-global it event-sym args) + (apply 'cc:signal-send channel event-sym args))) + + +(defun cc:signal-disconnect (channel deferred) + "Remove the observer object DEFERRED from CHANNEL and return +the removed deferred object. " + (let ((observers (cc:signal-observers channel)) deleted) + (setf + (cc:signal-observers channel) ; place + (loop for i in observers + for d = (cdr i) + unless (eq d deferred) + collect i + else + do (push i deleted))) + deleted)) + +(defun cc:signal-disconnect-all (channel) + "Remove all observers." + (setf + (cc:signal-observers channel) ; place + nil)) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Dataflow + +;; Dataflow variable entry +(defstruct cc:dataflow key (value 'cc:dataflow-undefine) deferred-list) + +(defun cc:dataflow-undefine-p (obj) + "[internal] If the variable entry is not bound, return `t'." + (eq 'cc:dataflow-undefine (cc:dataflow-value obj))) + +(defmacro cc:dataflow-parent-environment (df) + "[internal] Return the parent environment." + `(car ,df)) + +(defmacro cc:dataflow-test (df) + "[internal] Return the test function." + `(cadr ,df)) + +(defmacro cc:dataflow-channel (df) + "[internal] Return the channel object." + `(caddr ,df)) + +(defmacro cc:dataflow-list (df) + "[internal] Return the list of deferred object which are waiting for value binding." + `(cdddr ,df)) + +(defun cc:dataflow-environment (&optional parent-env test-func channel) + "Create a dataflow environment. +PARENT-ENV is the default environment. If this environment doesn't have the entry A and the parent one has the entry A, this environment can return the entry A. One can override the entry, setting another entry A to this environment. +TEST-FUNC is a test function that compares the entry keys. The default function is `equal'. +CHANNEL is a channel object that sends signals of variable events. Observers can receive following signals: +-get-first : the fist referrer is waiting for binding, +-get-waiting : another referrer is waiting for binding, +-set : a value is bound, +-get : returned a bound value, +-clear : cleared one entry, +-clear-all : cleared all entries. +" + (let ((this (list parent-env + (or test-func 'equal) + (or channel + (cc:signal-channel + 'dataflow + (and parent-env + (cc:dataflow-channel parent-env))))))) + (cc:dataflow-init-connect this) + this)) + +(defun cc:dataflow-init-connect (df) + "[internal] Initialize the channel object." + (lexical-let ((df df)) + (cc:dataflow-connect + df 'set + (lambda (args) + (destructuring-bind (_event (key)) args + (let* ((obj (cc:dataflow-get-object-for-value df key)) + (value (and obj (cc:dataflow-value obj)))) + (when obj + (loop for i in (cc:aif (cc:dataflow-get-object-for-deferreds df key) + (cc:dataflow-deferred-list it) nil) + do (deferred:callback-post i value)) + (setf (cc:dataflow-deferred-list obj) nil)))))))) + +(defun cc:dataflow-get-object-for-value (df key) + "[internal] Return an entry object that is indicated by KEY. +If the environment DF doesn't have the entry and the parent one has the entry, this function returns the entry of the parent environment. This function doesn't affect the waiting list." + (or + (loop for i in (cc:dataflow-list df) + with test = (cc:dataflow-test df) + if (and (funcall test key (cc:dataflow-key i)) + (not (cc:dataflow-undefine-p i))) + return i) + (deferred:aand + (cc:dataflow-parent-environment df) + (cc:dataflow-get-object-for-value it key)))) + +(defun cc:dataflow-get-object-for-deferreds (df key) + "[internal] Return a list of the deferred objects those are waiting for value binding. +This function doesn't affect the waiting list and doesn't refer the parent environment." + (loop for i in (cc:dataflow-list df) + with test = (cc:dataflow-test df) + if (funcall test key (cc:dataflow-key i)) + return i)) + +(defun cc:dataflow-connect (df event-sym &optional callback) + "Append an observer for EVENT-SYM of the channel of DF and return a deferred object. +See the docstring of `cc:dataflow-environment' for details." + (cc:signal-connect (cc:dataflow-channel df) event-sym callback)) + +(defun cc:dataflow-signal (df event &optional arg) + "[internal] Send a signal to the channel of DF." + (cc:signal-send (cc:dataflow-channel df) event arg)) + +(defun cc:dataflow-get (df key) + "Return a deferred object that can refer the value which is indicated by KEY. +If DF has the entry that bound value, the subsequent deferred task is executed immediately. +If not, the task is deferred till a value is bound." + (let ((obj (cc:dataflow-get-object-for-value df key))) + (cond + ((and obj (cc:dataflow-value obj)) + (cc:dataflow-signal df 'get key) + (deferred:succeed (cc:dataflow-value obj))) + (t + (setq obj (cc:dataflow-get-object-for-deferreds df key)) + (unless obj + (setq obj (make-cc:dataflow :key key)) + (push obj (cc:dataflow-list df)) + (cc:dataflow-signal df 'get-first key)) + (let ((d (deferred:new))) + (push d (cc:dataflow-deferred-list obj)) + (cc:dataflow-signal df 'get-waiting key) + d))))) + +(defun cc:dataflow-get-sync (df key) + "Return the value which is indicated by KEY synchronously. +If the environment DF doesn't have an entry of KEY, this function returns nil." + (let ((obj (cc:dataflow-get-object-for-value df key))) + (and obj (cc:dataflow-value obj)))) + +(defun cc:dataflow-set (df key value) + "Bind the VALUE to KEY in the environment DF. +If DF already has the bound entry of KEY, this function throws an error signal. +VALUE can be nil as a value." + (let ((obj (cc:dataflow-get-object-for-deferreds df key))) + (cond + ((and obj (not (cc:dataflow-undefine-p obj))) + ;; overwrite! + (error "Can not set a dataflow value. The key [%s] has already had a value. NEW:[%s] OLD:[%s]" key value (cc:dataflow-value obj))) + (obj + (setf (cc:dataflow-value obj) value)) + (t + ;; just value arrived + (push (make-cc:dataflow :key key :value value) + (cc:dataflow-list df)))) + ;; value arrived and start deferred objects + (cc:dataflow-signal df 'set key) + value)) + +(defun cc:dataflow-clear (df key) + "Clear the entry which is indicated by KEY. +This function does nothing for the waiting deferred objects." + (cc:dataflow-signal df 'clear key) + (setf (cc:dataflow-list df) + (loop for i in (cc:dataflow-list df) + with test = (cc:dataflow-test df) + unless (funcall test key (cc:dataflow-key i)) + collect i))) + +(defun cc:dataflow-get-avalable-pairs (df) + "Return an available key-value alist in the environment DF and the parent ones." + (append + (loop for i in (cc:dataflow-list df) + for key = (cc:dataflow-key i) + for val = (cc:dataflow-value i) + unless (cc:dataflow-undefine-p i) collect (cons key val)) + (deferred:aand + (cc:dataflow-parent-environment df) + (cc:dataflow-get-avalable-pairs it)))) + +(defun cc:dataflow-get-waiting-keys (df) + "Return a list of keys which have waiting deferred objects in the environment DF and the parent ones." + (append + (loop for i in (cc:dataflow-list df) + for key = (cc:dataflow-key i) + if (cc:dataflow-undefine-p i) collect key) + (deferred:aand + (cc:dataflow-parent-environment df) + (cc:dataflow-get-waiting-keys it)))) + +(defun cc:dataflow-clear-all (df) + "Clear all entries in the environment DF. +This function does nothing for the waiting deferred objects." + (cc:dataflow-signal df 'clear-all) + (setf (cc:dataflow-list df) nil)) + + +(provide 'concurrent) + +;; Local Variables: +;; byte-compile-warnings: (not cl-functions) +;; End: + +;;; concurrent.el ends here diff --git a/deferred.el b/deferred.el new file mode 100644 index 0000000..f589bb6 --- /dev/null +++ b/deferred.el @@ -0,0 +1,963 @@ +;;; deferred.el --- Simple asynchronous functions for emacs lisp + +;; Copyright (C) 2010-2016 SAKURAI Masashi + +;; Author: SAKURAI Masashi +;; Version: 0.4.0 +;; Keywords: deferred, async +;; URL: https://github.com/kiwanami/emacs-deferred + +;; 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 . + +;;; Commentary: + +;; 'deferred.el' is a simple library for asynchronous tasks. +;; [https://github.com/kiwanami/emacs-deferred] + +;; The API is almost the same as JSDeferred written by cho45. See the +;; JSDeferred and Mochikit.Async web sites for further documentations. +;; [https://github.com/cho45/jsdeferred] +;; [http://mochikit.com/doc/html/MochiKit/Async.html] + +;; A good introduction document (JavaScript) +;; [http://cho45.stfuawsc.com/jsdeferred/doc/intro.en.html] + +;;; Samples: + +;; ** HTTP Access + +;; (require 'url) +;; (deferred:$ +;; (deferred:url-retrieve "http://www.gnu.org") +;; (deferred:nextc it +;; (lambda (buf) +;; (insert (with-current-buffer buf (buffer-string))) +;; (kill-buffer buf)))) + +;; ** Invoking command tasks + +;; (deferred:$ +;; (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png") +;; (deferred:nextc it +;; (lambda (x) (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg"))) +;; (deferred:nextc it +;; (lambda (x) +;; (insert-image (create-image (expand-file-name "b.jpg") 'jpeg nil))))) + +;; See the readme for further API documentation. + +;; ** Applications + +;; *Inertial scrolling for Emacs +;; [https://github.com/kiwanami/emacs-inertial-scroll] + +;; This program makes simple multi-thread function, using +;; deferred.el. + +(require 'cl) + +(declare-function pp-display-expression 'pp) + +(defvar deferred:version nil "deferred.el version") +(setq deferred:version "0.4.0") + +;;; Code: + +(defmacro deferred:aand (test &rest rest) + "[internal] Anaphoric AND." + (declare (debug ("test" form &rest form))) + `(let ((it ,test)) + (if it ,(if rest `(deferred:aand ,@rest) 'it)))) + +(defmacro deferred:$ (&rest elements) + "Anaphoric function chain macro for deferred chains." + (declare (debug (&rest form))) + `(let (it) + ,@(loop for i in elements + collect + `(setq it ,i)) + it)) + +(defmacro deferred:lambda (args &rest body) + "Anaphoric lambda macro for self recursion." + (declare (debug ("args" form &rest form))) + (let ((argsyms (loop repeat (length args) collect (gensym)))) + `(lambda (,@argsyms) + (lexical-let (self) + (setq self (lambda( ,@args ) ,@body)) + (funcall self ,@argsyms))))) + +(defmacro* deferred:try (d &key catch finally) + "Try-catch-finally macro. This macro simulates the +try-catch-finally block asynchronously. CATCH and FINALLY can be +nil. Because of asynchrony, this macro does not ensure that the +task FINALLY should be called." + (let ((chain + (if catch `((deferred:error it ,catch))))) + (when finally + (setq chain (append chain `((deferred:watch it ,finally))))) + `(deferred:$ ,d ,@chain))) + +(defun deferred:setTimeout (f msec) + "[internal] Timer function that emulates the `setTimeout' function in JS." + (run-at-time (/ msec 1000.0) nil f)) + +(defun deferred:cancelTimeout (id) + "[internal] Timer cancellation function that emulates the `cancelTimeout' function in JS." + (cancel-timer id)) + +(defun deferred:run-with-idle-timer (sec f) + "[internal] Wrapper function for run-with-idle-timer." + (run-with-idle-timer sec nil f)) + +(defun deferred:call-lambda (f &optional arg) + "[internal] Call a function with one or zero argument safely. +The lambda function can define with zero and one argument." + (condition-case err + (funcall f arg) + ('wrong-number-of-arguments + (display-warning 'deferred "\ +Callback that takes no argument may be specified. +Passing callback with no argument is deprecated. +Callback must take one argument. +Or, this error is coming from somewhere inside of the callback: %S" err) + (condition-case nil + (funcall f) + ('wrong-number-of-arguments + (signal 'wrong-number-of-arguments (cdr err))))))) ; return the first error + +;; debug + +(eval-and-compile + (defvar deferred:debug nil "Debug output switch.")) +(defvar deferred:debug-count 0 "[internal] Debug output counter.") + +(defmacro deferred:message (&rest args) + "[internal] Debug log function." + (when deferred:debug + `(progn + (with-current-buffer (get-buffer-create "*deferred:debug*") + (save-excursion + (goto-char (point-max)) + (insert (format "%5i %s\n" deferred:debug-count (format ,@args))))) + (incf deferred:debug-count)))) + +(defun deferred:message-mark () + "[internal] Debug log function." + (interactive) + (deferred:message "==================== mark ==== %s" + (format-time-string "%H:%M:%S" (current-time)))) + +(defun deferred:pp (d) + (require 'pp) + (deferred:$ + (deferred:nextc d + (lambda (x) + (pp-display-expression x "*deferred:pp*"))) + (deferred:error it + (lambda (e) + (pp-display-expression e "*deferred:pp*"))) + (deferred:nextc it + (lambda (_x) (pop-to-buffer "*deferred:pp*"))))) + +(defvar deferred:debug-on-signal nil +"If non nil, the value `debug-on-signal' is substituted this +value in the `condition-case' form in deferred +implementations. Then, Emacs debugger can catch an error occurred +in the asynchronous tasks.") + +(defmacro deferred:condition-case (var protected-form &rest handlers) + "[internal] Custom condition-case. See the comment for +`deferred:debug-on-signal'." + (declare (debug condition-case) + (indent 2)) + `(let ((debug-on-signal + (or debug-on-signal deferred:debug-on-signal))) + (condition-case ,var + ,protected-form + ,@handlers))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Back end functions of deferred tasks + +(defvar deferred:tick-time 0.001 + "Waiting time between asynchronous tasks (second). +The shorter waiting time increases the load of Emacs. The end +user can tune this paramter. However, applications should not +modify it because the applications run on various environments.") + +(defvar deferred:queue nil + "[internal] The execution queue of deferred objects. +See the functions `deferred:post-task' and `deferred:worker'.") + +(defmacro deferred:pack (a b c) + `(cons ,a (cons ,b ,c))) + +(defun deferred:schedule-worker () + "[internal] Schedule consuming a deferred task in the execution queue." + (run-at-time deferred:tick-time nil 'deferred:worker)) + +(defun deferred:post-task (d which &optional arg) + "[internal] Add a deferred object to the execution queue +`deferred:queue' and schedule to execute. +D is a deferred object. WHICH is a symbol, `ok' or `ng'. ARG is +an argument value for execution of the deferred task." + (push (deferred:pack d which arg) deferred:queue) + (deferred:message "QUEUE-POST [%s]: %s" + (length deferred:queue) (deferred:pack d which arg)) + (deferred:schedule-worker) + d) + +(defun deferred:clear-queue () + "Clear the execution queue. For test and debugging." + (interactive) + (deferred:message "QUEUE-CLEAR [%s -> 0]" (length deferred:queue)) + (setq deferred:queue nil)) + +(defun deferred:worker () + "[internal] Consume a deferred task. +Mainly this function is called by timer asynchronously." + (when deferred:queue + (let* ((pack (car (last deferred:queue))) + (d (car pack)) + (which (cadr pack)) + (arg (cddr pack)) value) + (setq deferred:queue (nbutlast deferred:queue)) + (condition-case err + (setq value (deferred:exec-task d which arg)) + (error + (deferred:message "ERROR : %s" err) + (message "deferred error : %s" err))) + value))) + +(defun deferred:flush-queue! () + "Call all deferred tasks synchronously. For test and debugging." + (let (value) + (while deferred:queue + (setq value (deferred:worker))) + value)) + +(defun deferred:sync! (d) + "Wait for the given deferred task. For test and debugging. +Error is raised if it is not processed within deferred chain D." + (progn + (lexical-let ((last-value 'deferred:undefined*) + uncaught-error) + (deferred:try + (deferred:nextc d + (lambda (x) (setq last-value x))) + :catch + (lambda (err) (setq uncaught-error err))) + (while (and (eq 'deferred:undefined* last-value) + (not uncaught-error)) + (sit-for 0.05) + (sleep-for 0.05)) + (when uncaught-error + (deferred:resignal uncaught-error)) + last-value))) + + + +;; Struct: deferred +;; +;; callback : a callback function (default `deferred:default-callback') +;; errorback : an errorback function (default `deferred:default-errorback') +;; cancel : a canceling function (default `deferred:default-cancel') +;; next : a next chained deferred object (default nil) +;; status : if 'ok or 'ng, this deferred has a result (error) value. (default nil) +;; value : saved value (default nil) +;; +(defstruct deferred + (callback 'deferred:default-callback) + (errorback 'deferred:default-errorback) + (cancel 'deferred:default-cancel) + next status value) + +(defun deferred:default-callback (i) + "[internal] Default callback function." + (identity i)) + +(defun deferred:default-errorback (err) + "[internal] Default errorback function." + (deferred:resignal err)) + +(defun deferred:resignal (err) + "[internal] Safely resignal ERR as an Emacs condition. + +If ERR is a cons (ERROR-SYMBOL . DATA) where ERROR-SYMBOL has an +`error-conditions' property, it is re-signaled unchanged. If ERR +is a string, it is signaled as a generic error using `error'. +Otherwise, ERR is formatted into a string as if by `print' before +raising with `error'." + (cond ((and (listp err) + (symbolp (car err)) + (get (car err) 'error-conditions)) + (signal (car err) (cdr err))) + ((stringp err) + (error "%s" err)) + (t + (error "%S" err)))) + +(defun deferred:default-cancel (d) + "[internal] Default canceling function." + (deferred:message "CANCEL : %s" d) + (setf (deferred-callback d) 'deferred:default-callback) + (setf (deferred-errorback d) 'deferred:default-errorback) + (setf (deferred-next d) nil) + d) + +(defun deferred:exec-task (d which &optional arg) + "[internal] Executing deferred task. If the deferred object has +next deferred task or the return value is a deferred object, this +function adds the task to the execution queue. +D is a deferred object. WHICH is a symbol, `ok' or `ng'. ARG is +an argument value for execution of the deferred task." + (deferred:message "EXEC : %s / %s / %s" d which arg) + (when (null d) (error "deferred:exec-task was given a nil.")) + (let ((callback (if (eq which 'ok) + (deferred-callback d) + (deferred-errorback d))) + (next-deferred (deferred-next d))) + (cond + (callback + (deferred:condition-case err + (let ((value (deferred:call-lambda callback arg))) + (cond + ((deferred-p value) + (deferred:message "WAIT NEST : %s" value) + (if next-deferred + (deferred:set-next value next-deferred) + value)) + (t + (if next-deferred + (deferred:post-task next-deferred 'ok value) + (setf (deferred-status d) 'ok) + (setf (deferred-value d) value) + value)))) + (error + (cond + (next-deferred + (deferred:post-task next-deferred 'ng err)) + (deferred:onerror + (deferred:call-lambda deferred:onerror err)) + (t + (deferred:message "ERROR : %S" err) + (message "deferred error : %S" err) + (setf (deferred-status d) 'ng) + (setf (deferred-value d) err) + err))))) + (t ; <= (null callback) + (cond + (next-deferred + (deferred:exec-task next-deferred which arg)) + ((eq which 'ok) arg) + (t ; (eq which 'ng) + (deferred:resignal arg))))))) + +(defun deferred:set-next (prev next) + "[internal] Connect deferred objects." + (setf (deferred-next prev) next) + (cond + ((eq 'ok (deferred-status prev)) + (setf (deferred-status prev) nil) + (let ((ret (deferred:exec-task + next 'ok (deferred-value prev)))) + (if (deferred-p ret) ret + next))) + ((eq 'ng (deferred-status prev)) + (setf (deferred-status prev) nil) + (let ((ret (deferred:exec-task next 'ng (deferred-value prev)))) + (if (deferred-p ret) ret + next))) + (t + next))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Basic functions for deferred objects + +(defun deferred:new (&optional callback) + "Create a deferred object." + (if callback + (make-deferred :callback callback) + (make-deferred))) + +(defun deferred:callback (d &optional arg) + "Start deferred chain with a callback message." + (deferred:exec-task d 'ok arg)) + +(defun deferred:errorback (d &optional arg) + "Start deferred chain with an errorback message." + (deferred:exec-task d 'ng arg)) + +(defun deferred:callback-post (d &optional arg) + "Add the deferred object to the execution queue." + (deferred:post-task d 'ok arg)) + +(defun deferred:errorback-post (d &optional arg) + "Add the deferred object to the execution queue." + (deferred:post-task d 'ng arg)) + +(defun deferred:cancel (d) + "Cancel all callbacks and deferred chain in the deferred object." + (deferred:message "CANCEL : %s" d) + (funcall (deferred-cancel d) d) + d) + +(defun deferred:status (d) + "Return a current status of the deferred object. The returned value means following: +`ok': the callback was called and waiting for next deferred. +`ng': the errorback was called and waiting for next deferred. + nil: The neither callback nor errorback was not called." + (deferred-status d)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Basic utility functions + +(defvar deferred:onerror nil + "Default error handler. This value is nil or a function that + have one argument for the error message.") + +(defun deferred:succeed (&optional arg) + "Create a synchronous deferred object." + (let ((d (deferred:new))) + (deferred:exec-task d 'ok arg) + d)) + +(defun deferred:fail (&optional arg) + "Create a synchronous deferred object." + (let ((d (deferred:new))) + (deferred:exec-task d 'ng arg) + d)) + +(defun deferred:next (&optional callback arg) + "Create a deferred object and schedule executing. This function +is a short cut of following code: + (deferred:callback-post (deferred:new callback))." + (let ((d (if callback + (make-deferred :callback callback) + (make-deferred)))) + (deferred:callback-post d arg) + d)) + +(defun deferred:nextc (d callback) + "Create a deferred object with OK callback and connect it to the given deferred object." + (let ((nd (make-deferred :callback callback))) + (deferred:set-next d nd))) + +(defun deferred:error (d callback) + "Create a deferred object with errorback and connect it to the given deferred object." + (let ((nd (make-deferred :errorback callback))) + (deferred:set-next d nd))) + +(defun deferred:watch (d callback) + "Create a deferred object with watch task and connect it to the given deferred object. +The watch task CALLBACK can not affect deferred chains with +return values. This function is used in following purposes, +simulation of try-finally block in asynchronous tasks, progress +monitoring of tasks." + (lexical-let* + ((callback callback) + (normal (lambda (x) (ignore-errors (deferred:call-lambda callback x)) x)) + (err (lambda (e) + (ignore-errors (deferred:call-lambda callback e)) + (deferred:resignal e)))) + (let ((nd (make-deferred :callback normal :errorback err))) + (deferred:set-next d nd)))) + +(defun deferred:wait (msec) + "Return a deferred object scheduled at MSEC millisecond later." + (lexical-let + ((d (deferred:new)) (start-time (float-time)) timer) + (deferred:message "WAIT : %s" msec) + (setq timer (deferred:setTimeout + (lambda () + (deferred:exec-task d 'ok + (* 1000.0 (- (float-time) start-time))) + nil) msec)) + (setf (deferred-cancel d) + (lambda (x) + (deferred:cancelTimeout timer) + (deferred:default-cancel x))) + d)) + +(defun deferred:wait-idle (msec) + "Return a deferred object which will run when Emacs has been +idle for MSEC millisecond." + (lexical-let + ((d (deferred:new)) (start-time (float-time)) timer) + (deferred:message "WAIT-IDLE : %s" msec) + (setq timer + (deferred:run-with-idle-timer + (/ msec 1000.0) + (lambda () + (deferred:exec-task d 'ok + (* 1000.0 (- (float-time) start-time))) + nil))) + (setf (deferred-cancel d) + (lambda (x) + (deferred:cancelTimeout timer) + (deferred:default-cancel x))) + d)) + +(defun deferred:call (f &rest args) + "Call the given function asynchronously." + (lexical-let ((f f) (args args)) + (deferred:next + (lambda (_x) + (apply f args))))) + +(defun deferred:apply (f &optional args) + "Call the given function asynchronously." + (lexical-let ((f f) (args args)) + (deferred:next + (lambda (_x) + (apply f args))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utility functions + +(defun deferred:empty-p (times-or-seq) + "[internal] Return non-nil if TIMES-OR-SEQ is the number zero or nil." + (or (and (numberp times-or-seq) (<= times-or-seq 0)) + (and (sequencep times-or-seq) (= (length times-or-seq) 0)))) + +(defun deferred:loop (times-or-seq func) + "Return a iteration deferred object." + (deferred:message "LOOP : %s" times-or-seq) + (if (deferred:empty-p times-or-seq) (deferred:next) + (lexical-let* + (items (rd + (cond + ((numberp times-or-seq) + (loop for i from 0 below times-or-seq + with ld = (deferred:next) + do + (push ld items) + (setq ld + (lexical-let ((i i) (func func)) + (deferred:nextc ld (lambda (_x) (deferred:call-lambda func i))))) + finally return ld)) + ((sequencep times-or-seq) + (loop for i in (append times-or-seq nil) ; seq->list + with ld = (deferred:next) + do + (push ld items) + (setq ld + (lexical-let ((i i) (func func)) + (deferred:nextc ld (lambda (_x) (deferred:call-lambda func i))))) + finally return ld))))) + (setf (deferred-cancel rd) + (lambda (x) (deferred:default-cancel x) + (loop for i in items + do (deferred:cancel i)))) + rd))) + +(defun deferred:trans-multi-args (args self-func list-func main-func) + "[internal] Check the argument values and dispatch to methods." + (cond + ((and (= 1 (length args)) (consp (car args)) (not (functionp (car args)))) + (let ((lst (car args))) + (cond + ((or (null lst) (null (car lst))) + (deferred:next)) + ((deferred:aand lst (car it) (or (functionp it) (deferred-p it))) + ;; a list of deferred objects + (funcall list-func lst)) + ((deferred:aand lst (consp it)) + ;; an alist of deferred objects + (funcall main-func lst)) + (t (error "Wrong argument type. %s" args))))) + (t (funcall self-func args)))) + +(defun deferred:parallel-array-to-alist (lst) + "[internal] Translation array to alist." + (loop for d in lst + for i from 0 below (length lst) + collect (cons i d))) + +(defun deferred:parallel-alist-to-array (alst) + "[internal] Translation alist to array." + (loop for pair in + (sort alst (lambda (x y) + (< (car x) (car y)))) + collect (cdr pair))) + +(defun deferred:parallel-func-to-deferred (alst) + "[internal] Normalization for parallel and earlier arguments." + (loop for pair in alst + for d = (cdr pair) + collect + (progn + (unless (deferred-p d) + (setf (cdr pair) (deferred:next d))) + pair))) + +(defun deferred:parallel-main (alst) + "[internal] Deferred alist implementation for `deferred:parallel'. " + (deferred:message "PARALLEL" ) + (lexical-let ((nd (deferred:new)) + (len (length alst)) + values) + (loop for pair in + (deferred:parallel-func-to-deferred alst) + with cd ; current child deferred + do + (lexical-let ((name (car pair))) + (setq cd + (deferred:nextc (cdr pair) + (lambda (x) + (push (cons name x) values) + (deferred:message "PARALLEL VALUE [%s/%s] %s" + (length values) len (cons name x)) + (when (= len (length values)) + (deferred:message "PARALLEL COLLECTED") + (deferred:post-task nd 'ok (nreverse values))) + nil))) + (deferred:error cd + (lambda (e) + (push (cons name e) values) + (deferred:message "PARALLEL ERROR [%s/%s] %s" + (length values) len (cons name e)) + (when (= (length values) len) + (deferred:message "PARALLEL COLLECTED") + (deferred:post-task nd 'ok (nreverse values))) + nil)))) + nd)) + +(defun deferred:parallel-list (lst) + "[internal] Deferred list implementation for `deferred:parallel'. " + (deferred:message "PARALLEL" ) + (lexical-let* + ((pd (deferred:parallel-main (deferred:parallel-array-to-alist lst))) + (rd (deferred:nextc pd 'deferred:parallel-alist-to-array))) + (setf (deferred-cancel rd) + (lambda (x) (deferred:default-cancel x) + (deferred:cancel pd))) + rd)) + +(defun deferred:parallel (&rest args) + "Return a deferred object that calls given deferred objects or +functions in parallel and wait for all callbacks. The following +deferred task will be called with an array of the return +values. ARGS can be a list or an alist of deferred objects or +functions." + (deferred:message "PARALLEL : %s" args) + (deferred:trans-multi-args args + 'deferred:parallel 'deferred:parallel-list 'deferred:parallel-main)) + +(defun deferred:earlier-main (alst) + "[internal] Deferred alist implementation for `deferred:earlier'. " + (deferred:message "EARLIER" ) + (lexical-let ((nd (deferred:new)) + (len (length alst)) + value results) + (loop for pair in + (deferred:parallel-func-to-deferred alst) + with cd ; current child deferred + do + (lexical-let ((name (car pair))) + (setq cd + (deferred:nextc (cdr pair) + (lambda (x) + (push (cons name x) results) + (cond + ((null value) + (setq value (cons name x)) + (deferred:message "EARLIER VALUE %s" (cons name value)) + (deferred:post-task nd 'ok value)) + (t + (deferred:message "EARLIER MISS [%s/%s] %s" (length results) len (cons name value)) + (when (eql (length results) len) + (deferred:message "EARLIER COLLECTED")))) + nil))) + (deferred:error cd + (lambda (e) + (push (cons name e) results) + (deferred:message "EARLIER ERROR [%s/%s] %s" (length results) len (cons name e)) + (when (and (eql (length results) len) (null value)) + (deferred:message "EARLIER FAILED") + (deferred:post-task nd 'ok nil)) + nil)))) + nd)) + +(defun deferred:earlier-list (lst) + "[internal] Deferred list implementation for `deferred:earlier'. " + (deferred:message "EARLIER" ) + (lexical-let* + ((pd (deferred:earlier-main (deferred:parallel-array-to-alist lst))) + (rd (deferred:nextc pd (lambda (x) (cdr x))))) + (setf (deferred-cancel rd) + (lambda (x) (deferred:default-cancel x) + (deferred:cancel pd))) + rd)) + + +(defun deferred:earlier (&rest args) + "Return a deferred object that calls given deferred objects or +functions in parallel and wait for the first callback. The +following deferred task will be called with the first return +value. ARGS can be a list or an alist of deferred objects or +functions." + (deferred:message "EARLIER : %s" args) + (deferred:trans-multi-args args + 'deferred:earlier 'deferred:earlier-list 'deferred:earlier-main)) + +(defmacro deferred:timeout (timeout-msec timeout-form d) + "Time out macro on a deferred task D. If the deferred task D +does not complete within TIMEOUT-MSEC, this macro cancels the +deferred task and return the TIMEOUT-FORM." + `(deferred:earlier + (deferred:nextc (deferred:wait ,timeout-msec) + (lambda (x) ,timeout-form)) + ,d)) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Application functions + +(defvar deferred:uid 0 "[internal] Sequence number for some utilities. See the function `deferred:uid'.") + +(defun deferred:uid () + "[internal] Generate a sequence number." + (incf deferred:uid)) + +(defun deferred:buffer-string (strformat buf) + "[internal] Return a string in the buffer with the given format." + (format strformat + (with-current-buffer buf (buffer-string)))) + +(defun deferred:process (command &rest args) + "A deferred wrapper of `start-process'. Return a deferred +object. The process name and buffer name of the argument of the +`start-process' are generated by this function automatically. +The next deferred object receives stdout string from the command +process." + (deferred:process-gen 'start-process command args)) + +(defun deferred:process-shell (command &rest args) + "A deferred wrapper of `start-process-shell-command'. Return a deferred +object. The process name and buffer name of the argument of the +`start-process-shell-command' are generated by this function automatically. +The next deferred object receives stdout string from the command +process." + (deferred:process-gen 'start-process-shell-command command args)) + +(defun deferred:process-buffer (command &rest args) + "A deferred wrapper of `start-process'. Return a deferred +object. The process name and buffer name of the argument of the +`start-process' are generated by this function automatically. +The next deferred object receives stdout buffer from the command +process." + (deferred:process-buffer-gen 'start-process command args)) + +(defun deferred:process-shell-buffer (command &rest args) + "A deferred wrapper of `start-process-shell-command'. Return a deferred +object. The process name and buffer name of the argument of the +`start-process-shell-command' are generated by this function automatically. +The next deferred object receives stdout buffer from the command +process." + (deferred:process-buffer-gen 'start-process-shell-command command args)) + +(defun deferred:process-gen (f command args) + "[internal]" + (lexical-let + ((pd (deferred:process-buffer-gen f command args)) d) + (setq d (deferred:nextc pd + (lambda (buf) + (prog1 + (with-current-buffer buf (buffer-string)) + (kill-buffer buf))))) + (setf (deferred-cancel d) + (lambda (_x) + (deferred:default-cancel d) + (deferred:default-cancel pd))) + d)) + +(defun deferred:process-buffer-gen (f command args) + "[internal]" + (let ((d (deferred:next)) (uid (deferred:uid))) + (lexical-let + ((f f) (command command) (args args) + (proc-name (format "*deferred:*%s*:%s" command uid)) + (buf-name (format " *deferred:*%s*:%s" command uid)) + (pwd default-directory) + (env process-environment) + (con-type process-connection-type) + (nd (deferred:new)) proc-buf proc) + (deferred:nextc d + (lambda (_x) + (setq proc-buf (get-buffer-create buf-name)) + (condition-case err + (let ((default-directory pwd) + (process-environment env) + (process-connection-type con-type)) + (setq proc + (if (null (car args)) + (apply f proc-name buf-name command nil) + (apply f proc-name buf-name command args))) + (set-process-sentinel + proc + (lambda (_proc event) + (cond + ((string-match "exited abnormally" event) + (let ((msg (if (buffer-live-p proc-buf) + (format "Process [%s] exited abnormally : %s" + command + (with-current-buffer proc-buf (buffer-string))) + (concat "Process exited abnormally: " proc-name)))) + (kill-buffer proc-buf) + (deferred:post-task nd 'ng msg))) + ((equal event "finished\n") + (deferred:post-task nd 'ok proc-buf))))) + (setf (deferred-cancel nd) + (lambda (x) (deferred:default-cancel x) + (when proc + (kill-process proc) + (kill-buffer proc-buf))))) + (error (deferred:post-task nd 'ng err))) + nil)) + nd))) + +(defmacro deferred:processc (d command &rest args) + "Process chain of `deferred:process'." + `(deferred:nextc ,d + (lambda (,(gensym)) (deferred:process ,command ,@args)))) + +(defmacro deferred:process-bufferc (d command &rest args) + "Process chain of `deferred:process-buffer'." + `(deferred:nextc ,d + (lambda (,(gensym)) (deferred:process-buffer ,command ,@args)))) + +(defmacro deferred:process-shellc (d command &rest args) + "Process chain of `deferred:process'." + `(deferred:nextc ,d + (lambda (,(gensym)) (deferred:process-shell ,command ,@args)))) + +(defmacro deferred:process-shell-bufferc (d command &rest args) + "Process chain of `deferred:process-buffer'." + `(deferred:nextc ,d + (lambda (,(gensym)) (deferred:process-shell-buffer ,command ,@args)))) + +(eval-after-load "url" + ;; for url package + ;; TODO: proxy, charaset + ;; List of gloabl variables to preserve and restore before url-retrieve call + '(lexical-let ((url-global-variables '(url-request-data + url-request-method + url-request-extra-headers))) + + (defun deferred:url-retrieve (url &optional cbargs silent inhibit-cookies) + "A wrapper function for url-retrieve. The next deferred +object receives the buffer object that URL will load +into. Values of dynamically bound 'url-request-data', 'url-request-method' and +'url-request-extra-headers' are passed to url-retrieve call." + (lexical-let ((nd (deferred:new)) (url url) + (cbargs cbargs) (silent silent) (inhibit-cookies inhibit-cookies) buf + (local-values (mapcar (lambda (symbol) (symbol-value symbol)) url-global-variables))) + (deferred:next + (lambda (_x) + (progv url-global-variables local-values + (condition-case err + (setq buf + (url-retrieve + url (lambda (_xx) (deferred:post-task nd 'ok buf)) + cbargs silent inhibit-cookies)) + (error (deferred:post-task nd 'ng err))) + nil))) + (setf (deferred-cancel nd) + (lambda (_x) + (when (buffer-live-p buf) + (kill-buffer buf)))) + nd)) + + (defun deferred:url-delete-header (buf) + (with-current-buffer buf + (let ((pos (url-http-symbol-value-in-buffer + 'url-http-end-of-headers buf))) + (when pos + (delete-region (point-min) (1+ pos))))) + buf) + + (defun deferred:url-delete-buffer (buf) + (when (and buf (buffer-live-p buf)) + (kill-buffer buf)) + nil) + + (defun deferred:url-get (url &optional params &rest args) + "Perform a HTTP GET method with `url-retrieve'. PARAMS is +a parameter list of (key . value) or key. ARGS will be appended +to deferred:url-retrieve args list. The next deferred +object receives the buffer object that URL will load into." + (when params + (setq url + (concat url "?" (deferred:url-param-serialize params)))) + (let ((d (deferred:$ + (apply 'deferred:url-retrieve url args) + (deferred:nextc it 'deferred:url-delete-header)))) + (deferred:set-next + d (deferred:new 'deferred:url-delete-buffer)) + d)) + + (defun deferred:url-post (url &optional params &rest args) + "Perform a HTTP POST method with `url-retrieve'. PARAMS is +a parameter list of (key . value) or key. ARGS will be appended +to deferred:url-retrieve args list. The next deferred +object receives the buffer object that URL will load into." + (let ((url-request-method "POST") + (url-request-extra-headers + (append url-request-extra-headers + '(("Content-Type" . "application/x-www-form-urlencoded")))) + (url-request-data (deferred:url-param-serialize params))) + (let ((d (deferred:$ + (apply 'deferred:url-retrieve url args) + (deferred:nextc it 'deferred:url-delete-header)))) + (deferred:set-next + d (deferred:new 'deferred:url-delete-buffer)) + d))) + + (defun deferred:url-escape (val) + "[internal] Return a new string that is VAL URI-encoded." + (unless (stringp val) + (setq val (format "%s" val))) + (url-hexify-string + (encode-coding-string val 'utf-8))) + + (defun deferred:url-param-serialize (params) + "[internal] Serialize a list of (key . value) cons cells +into a query string." + (when params + (mapconcat + 'identity + (loop for p in params + collect + (cond + ((consp p) + (concat + (deferred:url-escape (car p)) "=" + (deferred:url-escape (cdr p)))) + (t + (deferred:url-escape p)))) + "&"))) + )) + + +(provide 'deferred) +;;; deferred.el ends here diff --git a/sample/concurrent-sample.el b/sample/concurrent-sample.el new file mode 100644 index 0000000..ae1bca6 --- /dev/null +++ b/sample/concurrent-sample.el @@ -0,0 +1,183 @@ +;;; Sample code for concurrent.el + +;; Evaluate following code in the scratch buffer. + +;;================================================== +;;; generator + +(setq fib-list nil) + +(setq fib-gen ; Create a generator object. + (lexical-let ((a1 0) (a2 1)) + (cc:generator + (lambda (x) (push x fib-list)) ; receiving values + (yield a1) + (yield a2) + (while t + (let ((next (+ a1 a2))) + (setq a1 a2 + a2 next) + (yield next)))))) + +(funcall fib-gen) ; Generate 5 times +(funcall fib-gen) (funcall fib-gen) +(funcall fib-gen) (funcall fib-gen) + +fib-list ;=> (3 2 1 1 0) + + +;;================================================== +;;; thread + +(lexical-let + ((count 0) (anm "-/|\\-") + (end 50) (pos (point))) + (cc:thread + 60 + (message "Animation started.") + (while (> end (incf count)) + (save-excursion + (when (< 1 count) + (goto-char pos) (delete-char 1)) + (insert (char-to-string + (aref anm (% count (length anm))))))) + (save-excursion + (goto-char pos) (delete-char 1)) + (message "Animation finished."))) + +;; Play the simple character animation here. + + +;;================================================== +;;; semaphore + +;; create a semaphore object with permit=1. +(setq smp (cc:semaphore-create 1)) + +;; executing three tasks... +(deferred:nextc (cc:semaphore-acquire smp) + (lambda(x) + (message "go1"))) +(deferred:nextc (cc:semaphore-acquire smp) + (lambda(x) + (message "go2"))) +(deferred:nextc (cc:semaphore-acquire smp) + (lambda(x) + (message "go3"))) + +;; => Only the fist task is executed and displays "go1". + +(cc:semaphore-release smp) + +;; => The second task is executed and displays "go2". + +(cc:semaphore-waiting-deferreds smp) ; return the deferred object that displays "go3". + +(cc:semaphore-release-all smp) ; => reset permit count and return the deferred object that displays "go3". + +(cc:semaphore-waiting-deferreds smp) ; => nil + + +;;================================================== +;; Dataflow + +;; create a parent environment and bind "aaa" to 256. +(setq dfenv-parent (cc:dataflow-environment)) +(cc:dataflow-set dfenv-parent "aaa" 256) + +;; create an environment with the parent one. +(setq dfenv (cc:dataflow-environment dfenv-parent)) + +;; Return the parent value. +(cc:dataflow-get-sync dfenv "aaa") ; => 256 + +(deferred:$ + (cc:dataflow-get dfenv "abc") + (deferred:nextc it + (lambda (x) (message "Got abc : %s" x)))) +;; => This task is blocked + +(cc:dataflow-set dfenv "abc" 256) ; bind 256 to "abc" + +;; => The blocked task is executed and displays "Got abc : 256". + +(cc:dataflow-get-sync dfenv "abc") ; => 256 + +;; unbind the variable "abc" +(cc:dataflow-clear dfenv "abc") + +(cc:dataflow-get-sync dfenv "abc") ; => nil + + +;; complicated key (`equal' can compare nested lists.) + +(deferred:$ + (cc:dataflow-get dfenv '("http://example.com/a.jpg" 300)) + (deferred:nextc it + (lambda (x) (message "a.jpg:300 OK %s" x)))) + +(cc:dataflow-set dfenv '("http://example.com/a.jpg" 300) 'jpeg) + +;; waiting for two variables + +(deferred:$ + (deferred:parallel + (cc:dataflow-get dfenv "abc") + (cc:dataflow-get dfenv "def")) + (deferred:nextc it + (lambda (values) + (apply 'message "Got values : %s, %s" values) + (apply '+ values))) + (deferred:nextc it + (lambda (x) (insert (format ">> %s" x))))) + +(cc:dataflow-get-waiting-keys dfenv) ; => ("def" "abc") +(cc:dataflow-get-avalable-pairs dfenv) ; => (("aaa" . 256)) + +(cc:dataflow-set dfenv "abc" 128) +(cc:dataflow-set dfenv "def" 256) + +;; => "Got values : 128, 256" +;; inserted ">> 384" + +(cc:dataflow-get-avalable-pairs dfenv) + +(cc:dataflow-clear-all dfenv) + +(cc:dataflow-get-avalable-pairs dfenv) + + +;;================================================== +;; Signal + +(progn + (setq parent-channel (cc:signal-channel "parent")) + (cc:signal-connect + parent-channel 'parent-load + (lambda (event) (message "Parent Signal : %s" event))) + (cc:signal-connect + parent-channel t + (lambda (event) (message "Parent Listener : %s" event))) + + (setq channel (cc:signal-channel "child" parent-channel)) + (cc:signal-connect + channel 'window-load + (lambda (event) (message "Signal : %s" event))) + (cc:signal-connect + channel t + (lambda (event) (message "Listener : %s" event))) + (deferred:$ + (cc:signal-connect channel 'window-load) + (deferred:nextc it + (lambda (x) (message "Deferred Signal : %s" x)))) + ) + +(cc:signal-send channel 'window-load "hello signal!") +(cc:signal-send channel 'some "some signal!") + +(cc:signal-send parent-channel 'parent-load "parent hello!") +(cc:signal-send parent-channel 'window-load "parent hello!") +(cc:signal-send parent-channel 'some "parent some hello!") +(cc:signal-send-global channel 'some "parent some hello!") + +(cc:signal-disconnect-all channel) diff --git a/sample/deferred-samples.el b/sample/deferred-samples.el new file mode 100644 index 0000000..7ad3d5a --- /dev/null +++ b/sample/deferred-samples.el @@ -0,0 +1,165 @@ +;; deferred.el samples + +(require 'deferred) + +;;; Basic Chain + +(deferred:$ + (deferred:next + (lambda () (message "deferred start"))) + (deferred:nextc it + (lambda () + (message "chain 1") + 1)) + (deferred:nextc it + (lambda (x) + (message "chain 2 : %s" x))) + (deferred:nextc it + (lambda () + (read-minibuffer "Input a number: "))) + (deferred:nextc it + (lambda (x) + (message "Got the number : %i" x))) + (deferred:error it + (lambda (err) + (message "Wrong input : %s" err)))) + + +;;; Timer + +(deferred:$ + (deferred:wait 1000) ; 1000msec + (deferred:nextc it + (lambda (x) + (message "Timer sample! : %s msec" x)))) + + +;;; Command process + +(deferred:$ + (deferred:process "ls" "-la") + (deferred:nextc it + (lambda (x) (insert x)))) + + +;;; Web Access + +;; Simple web access + +(require 'url) + +(deferred:$ + (deferred:url-retrieve "http://www.gnu.org") + (deferred:nextc it + (lambda (buf) + (insert (with-current-buffer buf (buffer-string))) + (kill-buffer buf)))) + +;; Get an image + +(deferred:$ + (deferred:url-retrieve "http://www.google.co.jp/intl/en_com/images/srpr/logo1w.png") + (deferred:nextc it + (lambda (buf) + (insert-image + (create-image + (let ((data (with-current-buffer buf (buffer-string)))) + (substring data (+ (string-match "\n\n" data) 2))) + 'png t)) + (kill-buffer buf)))) + +;; HTTP POST + +(deferred:$ + (deferred:url-post + "http://127.0.0.1:8080/post-test.cgi" + '(('a . "test") ('param . "OK"))) + (deferred:nextc it + (lambda (buf) + (insert (with-current-buffer buf (buffer-string))) + (kill-buffer buf)))) + + +;; Parallel deferred + +(deferred:$ + (deferred:parallel + (lambda () + (deferred:url-retrieve "http://www.google.co.jp/intl/en_com/images/srpr/logo1w.png")) + (lambda () + (deferred:url-retrieve "http://www.google.co.jp/images/srpr/nav_logo14.png"))) + (deferred:nextc it + (lambda (buffers) + (loop for i in buffers + do + (insert + (format + "size: %s\n" + (with-current-buffer i (length (buffer-string))))) + (kill-buffer i))))) + +;; Get an image by wget and resize by ImageMagick + +(deferred:$ + + ;; try + (deferred:$ + (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png") + (deferred:nextc it + (lambda () (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg"))) + (deferred:nextc it + (lambda () + (clear-image-cache) + (insert-image (create-image (expand-file-name "b.jpg") 'jpeg nil))))) + + ;; catch + (deferred:error it ; + (lambda (err) + (insert "Can not get a image! : " err))) + + ;; finally + (deferred:nextc it + (lambda () + (deferred:parallel + (lambda () (delete-file "a.jpg")) + (lambda () (delete-file "b.jpg"))))) + (deferred:nextc it + (lambda (x) (message ">> %s" x)))) + + +;; Timeout Process + +(deferred:$ + (deferred:earlier + (deferred:process "sh" "-c" "sleep 3 | echo 'hello!'") + (deferred:$ + (deferred:wait 1000) ; timeout msec + (deferred:nextc it (lambda () "canceled!")))) + (deferred:nextc it + (lambda (x) (insert x)))) + + +;; Loop and animation + +(lexical-let ((count 0) (anm "-/|\\-") + (end 50) (pos (point)) + (wait-time 50)) + (deferred:$ + (deferred:next + (lambda (x) (message "Animation started."))) + + (deferred:nextc it + (deferred:lambda (x) + (save-excursion + (when (< 0 count) + (goto-char pos) (delete-char 1)) + (insert (char-to-string + (aref anm (% count (length anm)))))) + (if (> end (incf count)) + (deferred:nextc (deferred:wait wait-time) self)))) + + (deferred:nextc it + (lambda (x) + (save-excursion + (goto-char pos) (delete-char 1)) + (message "Animation finished."))))) diff --git a/test/concurrent-test.el b/test/concurrent-test.el new file mode 100644 index 0000000..5e190e6 --- /dev/null +++ b/test/concurrent-test.el @@ -0,0 +1,620 @@ +;;; test code for concurrent.el + +;; Copyright (C) 2010 SAKURAI Masashi +;; Author: SAKURAI Masashi + +;; 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 . + +;; How to run this test ? +;; $ emacs -L . -L $HOME/.emacs.d/elisp -batch -l deferred -l concurrent -l test-concurrent -f cc:test-all + +(require 'undercover) +(undercover "concurrent.el" + (:send-report nil) + (:report-file "/tmp/undercover-report.json")) +(require 'concurrent) +(require 'cl) +(require 'pp) +(require 'ert) + +(defmacro cc:debug (d msg &rest args) + `(deferred:nextc ,d + (lambda (x) (funcall 'message ,msg ,@args) x))) + +;; generator + +(defun cc:fib-gen (callback) + (lexical-let ((a1 0) (a2 1) + (callback callback)) + (cc:generator + callback + (yield a1) + (yield a2) + (while t + (let ((next (+ a1 a2))) + (setq a1 a2 + a2 next) + (yield next)))))) + +(defun cc:test-fib-gen () + (lexical-let* + ((count 0) + (dfinish (deferred:new)) + gen + (cc (lambda (x) + (cond + ((= count 10) + (deferred:callback + dfinish + (if (= x 55) t + (format "Fib 10 = 55 -> %s" x)))) + (t + (incf count) + (deferred:call gen)))))) + (setq gen (cc:fib-gen cc)) + (deferred:call gen) + dfinish)) + +;; (cc:debug (cc:test-fib-gen) "Fib10 : %s" x) + +;; thread + +(defun cc:test-thread () + (lexical-let + ((dfinish (deferred:new)) + (result nil) (start-time (float-time)) + (count 0) (end 20)) + (push 1 result) + (cc:thread + 60 + (push 2 result) + (while (> end (incf count)) + (when (= 0 (% count 10)) + (push count result))) + (push 99 result) + (setq result (reverse result)) + (deferred:callback dfinish + (and (or (equal '(1 2 10 99) result) result) + (let ((elapsed-time (- (float-time) start-time))) + (or (and (< 1.0 elapsed-time) (< elapsed-time 6)) elapsed-time))))) + dfinish)) + +;; (cc:debug (cc:test-thread) "Thread : %s" x) + +;; semaphore + +(defun cc:test-semaphore1 () + (lexical-let* + ((result nil) + (dfinish (deferred:new + (lambda (x) + (setq result (reverse result)) + (or (equal '(1 2 5 6 (size . 1) 3 7 8 canceled (size . 0)) result) + result)))) + (smp (cc:semaphore-create 1))) + + (push 1 result) + + (deferred:nextc (cc:semaphore-acquire smp) + (lambda(x) (push 2 result))) + (deferred:nextc (cc:semaphore-acquire smp) + (lambda(x) (push 3 result))) + (deferred:nextc (cc:semaphore-acquire smp) + (lambda(x) (push x result))) + + (deferred:$ + (deferred:next + (lambda (x) + (push 5 result) + (cc:semaphore-release smp) + (push 6 result))) + (deferred:nextc it + (lambda (x) + (push (cons 'size (length (cc:semaphore-waiting-deferreds smp))) result))) + (deferred:nextc it + (lambda (x) + (push 7 result) + (loop for i in (cc:semaphore-release-all smp) + do (deferred:callback i 'canceled)) + (push 8 result))) + (deferred:nextc it + (lambda (x) + (push (cons 'size (length (cc:semaphore-waiting-deferreds smp))) result))) + (deferred:nextc it + (lambda (x) (deferred:callback dfinish)))) + + dfinish)) + +;; (cc:debug (cc:test-semaphore1) "Semaphore1 : %s" x) + +(defun cc:test-semaphore2 () + (lexical-let* + ((result nil) + (dfinish (deferred:new + (lambda (x) + (setq result (reverse result)) + (or (equal '(0 a b c d e f g) result) + result)))) + (smp (cc:semaphore-create 1))) + + (push 0 result) + + (cc:semaphore-with + smp (lambda (x) + (deferred:nextc (cc:semaphore-acquire smp) + (lambda (x) + (push 'c result) + (cc:semaphore-release smp))) + (push 'a result) + (deferred:nextc + (deferred:wait 100) + (lambda (x) (push 'b result))))) + + (cc:semaphore-with + smp (lambda (x) + (deferred:nextc (cc:semaphore-acquire smp) + (lambda (x) + (push 'g result) + (cc:semaphore-release smp) + (deferred:callback dfinish))) + (push 'd result) + (deferred:nextc + (deferred:wait 100) + (lambda (x) + (push 'e result) + (error "SMP CC ERR")))) + (lambda (e) + (destructuring-bind (sym msg) e + (when (and (eq 'error sym) (equal "SMP CC ERR" msg)) + (push 'f result))))) + + dfinish)) + +;; (cc:debug (cc:test-semaphore2) "Semaphore2 : %s" x) + +;; Dataflow + +(defun cc:test-dataflow-simple1 () + (lexical-let* + ((result '(1)) + (dfinish (deferred:new + (lambda (x) + (setq result (reverse result)) + (or (equal '(1 (2 . nil) 4 5 (3 . 256) (6 . 256) (7 . nil)) result) + result)))) + (dfenv (cc:dataflow-environment))) + + (push (cons 2 (cc:dataflow-get-sync dfenv "aaa")) result) + + (deferred:$ + (deferred:parallel + (deferred:$ + (cc:dataflow-get dfenv "abc") + (deferred:nextc it + (lambda (x) (push (cons 3 x) result)))) + (deferred:$ + (deferred:next + (lambda (x) + (push 4 result) + (cc:dataflow-set dfenv "abc" 256) + (push 5 result))))) + (deferred:nextc it + (lambda (x) + (push (cons 6 (cc:dataflow-get-sync dfenv "abc")) result) + (cc:dataflow-clear dfenv "abc") + (push (cons 7 (cc:dataflow-get-sync dfenv "abc")) result))) + (deferred:nextc it + (lambda (x) + (deferred:callback dfinish)))) + + dfinish)) + +;; (cc:debug (cc:test-dataflow-simple1) "Dataflow1 : %s" x) + +(defun cc:test-dataflow-simple2 () + (lexical-let* + ((result nil) + (dfinish (deferred:new + (lambda (x) + (or (equal '("a.jpg:300 OK jpeg") result) + result)))) + (dfenv (cc:dataflow-environment))) + + (deferred:$ + (cc:dataflow-get dfenv '("http://example.com/a.jpg" 300)) + (deferred:nextc it + (lambda (x) (push (format "a.jpg:300 OK %s" x) result))) + (deferred:nextc it + (lambda (x) + (deferred:callback dfinish)))) + + (cc:dataflow-set dfenv '("http://example.com/a.jpg" 300) 'jpeg) + + dfinish)) + +;; (cc:debug (cc:test-dataflow-simple2) "Dataflow2 : %s" x) + +(defun cc:test-dataflow-simple3 () + (lexical-let* + ((result nil) + (dfinish (deferred:new + (lambda (x) + (or (equal '(">> 384") result) + result)))) + (dfenv (cc:dataflow-environment))) + + (deferred:$ + (deferred:parallel + (cc:dataflow-get dfenv "def") + (cc:dataflow-get dfenv "abc")) + (deferred:nextc it + (lambda (values) + (apply '+ values))) + (deferred:nextc it + (lambda (x) (push (format ">> %s" x) result))) + (deferred:nextc it + (lambda (x) + (deferred:callback dfinish)))) + + (deferred:nextc (deferred:wait 0.2) + (lambda (x) + (cc:dataflow-set dfenv "def" 128) + (cc:dataflow-set dfenv "abc" 256) + (cc:dataflow-set dfenv "aaa" 512) + )) + + dfinish)) + +;; (cc:debug (cc:test-dataflow-simple3) "Dataflow3 : %s" x) + +(defun cc:test-dataflow-simple4 () + (lexical-let* + ((result nil) + (dfinish (deferred:new + (lambda (x) + (or (equal '(">> 3") result) + result)))) + (dfenv (cc:dataflow-environment))) + + (deferred:$ + (deferred:parallel + (cc:dataflow-get dfenv "abc") + (cc:dataflow-get dfenv "abc") + (cc:dataflow-get dfenv "abc")) + (deferred:nextc it + (lambda (values) + (apply '+ values))) + (deferred:nextc it + (lambda (x) (push (format ">> %s" x) result))) + (deferred:nextc it + (lambda (x) + (deferred:callback dfinish)))) + + (deferred:nextc (deferred:wait 0.2) + (lambda (x) + (cc:dataflow-set dfenv "abc" 1) + )) + + dfinish)) + +;; (cc:debug (cc:test-dataflow-simple4) "Dataflow4 : %s" x) + +(defun cc:test-dataflow-signal () + (lexical-let* + ((result '(1)) + (dfinish (deferred:new + (lambda (x) + (setq result (reverse result)) + (or (equal + '(1 + (2 . nil) + (get-first ("abc")) + (get-waiting ("abc")) + 4 5 + (set ("abc")) + (3 . 256) + 6 7 + (get ("abc")) + (8 . 256) + (9 . nil) + (clear ("abc")) + (clear-all (nil)) + ) result) + result)))) + (dfenv (cc:dataflow-environment))) + + (loop for i in '(get get-first get-waiting set clear clear-all) + do (cc:dataflow-connect dfenv i (lambda (ev) (push ev result)))) + + (push (cons 2 (cc:dataflow-get-sync dfenv "aaa")) result) + + (deferred:$ + (deferred:parallel + (deferred:$ + (cc:dataflow-get dfenv "abc") + (deferred:nextc it + (lambda (x) (push (cons 3 x) result)))) + (deferred:$ + (deferred:next + (lambda (x) + (push 4 result) + (cc:dataflow-set dfenv "abc" 256) + (push 5 result))))) + (deferred:nextc it + (lambda (x) + (push 6 result) + (cc:dataflow-get dfenv "abc") + (push 7 result))) + (deferred:nextc it + (lambda (x) + (push (cons 8 (cc:dataflow-get-sync dfenv "abc")) result) + (cc:dataflow-clear dfenv "abc") + (push (cons 9 (cc:dataflow-get-sync dfenv "abc")) result))) + (deferred:nextc it + (lambda (x) + (cc:dataflow-clear-all dfenv))) + (deferred:nextc it + (lambda (x) + (deferred:callback dfinish)))) + + dfinish)) + +;; (cc:debug (cc:test-dataflow-signal) "Dataflow Signal : %s" x) + + +(defun cc:test-dataflow-parent1 () + (lexical-let* + ((result '(1)) + (dfinish (deferred:new + (lambda (x) + (setq result (reverse result)) + (or (equal + '(1 + (available-parent . (("abc" . 128))) + (available-child . (("abc" . 128))) + (waiting-parent . nil) + (waiting-child . ("aaa")) + (get-sync . 256) + (get . 256) + ) result) + result)))) + (dfenv-parent (cc:dataflow-environment)) + (dfenv (cc:dataflow-environment dfenv-parent))) + + (cc:dataflow-set dfenv-parent "abc" 128) + + (deferred:$ + (deferred:parallel + (deferred:$ + (cc:dataflow-get dfenv "aaa") + (deferred:nextc it + (lambda (x) (push (cons 'get x) result)))) + (deferred:$ + (deferred:next + (lambda (x) + (push (cons 'available-parent (cc:dataflow-get-avalable-pairs dfenv-parent)) result) + (push (cons 'available-child (cc:dataflow-get-avalable-pairs dfenv)) result) + (push (cons 'waiting-parent (cc:dataflow-get-waiting-keys dfenv-parent)) result) + (push (cons 'waiting-child (cc:dataflow-get-waiting-keys dfenv)) result))) + (deferred:next + (lambda (x) + (cc:dataflow-set dfenv-parent "aaa" 256) + (push (cons 'get-sync (cc:dataflow-get-sync dfenv "aaa")) result))))) + (deferred:nextc it + (lambda (x) (deferred:callback dfinish)))) + + dfinish)) + +;; (cc:debug (cc:test-dataflow-parent1) "Dataflow Parent1 : %s" x) + +(defun cc:test-dataflow-parent2 () + (lexical-let* + ((result '()) + (dfinish (deferred:new + (lambda (x) + (setq result (reverse result)) + (or (equal + '("parent get 256" "child get 256") result) + result)))) + (dfenv-parent (cc:dataflow-environment)) + (dfenv (cc:dataflow-environment dfenv-parent))) + + (deferred:$ + (deferred:parallel + (deferred:$ + (cc:dataflow-get dfenv-parent "abc") + (deferred:nextc it + (lambda (x) (push (format "parent get %s" x) result)))) + (deferred:$ + (cc:dataflow-get dfenv "abc") + (deferred:nextc it + (lambda (x) (push (format "child get %s" x) result)))) + (deferred:nextc (deferred:wait 0.2) + (lambda (x) (cc:dataflow-set dfenv-parent "abc" 256)))) + (deferred:nextc it + (lambda (x) (deferred:callback dfinish)))) + + dfinish)) + +;; (cc:debug (cc:test-dataflow-parent2) "Dataflow Parent : %s" x) + + +;; Signal + +(defun cc:test-signal1 () + (lexical-let* + ((result '()) + (dfinish (deferred:new + (lambda (x) + (setq result (reverse result)) + (or (equal + '( + (ls ev1 (1)) + (sig ev1 (1)) + (ls ev2 (2)) + (def ev1 (1)) + ) result) + result)))) + (channel (cc:signal-channel "child"))) + + (cc:signal-connect channel 'ev1 + (lambda (event) + (push (cons 'sig event) result))) + (cc:signal-connect channel t + (lambda (event) + (push (cons 'ls event) result))) + (deferred:$ + (cc:signal-connect channel 'ev1) + (deferred:nextc it + (lambda (x) (push (cons 'def x) result)))) + + (deferred:$ + (deferred:next + (lambda (x) + (cc:signal-send channel 'ev1 1) + (cc:signal-send channel 'ev2 2))) + (deferred:nextc it + (lambda (x) (deferred:wait 300))) + (deferred:nextc it + (lambda (x) + (deferred:callback dfinish)))) + + dfinish)) + +;; (cc:debug (cc:test-signal1) "Signal1 : %s" x) + +;; (cc:debug (cc:test-signal2) "Signal2 : %s" x) + +(defun cc:test-signal2 () + (lexical-let* + ((result nil) + (dfinish (deferred:new + (lambda (x) + (setq result (reverse result)) + (or (equal + '( + (pls pev1 (1)) + (psig pev1 (1)) + (pls ev1 (2)) + (ls ev1 (3)) + (sig ev1 (3)) + (pls ev2 (4)) + (pls ev2 (5)) + + (ls pev1 (1)) + (ls ev1 (2)) + + (sig ev1 (2)) + (def ev1 (3)) + (ls ev2 (4)) + (ls ev2 (5)) + + (def ev1 (2)) + ) + result) + result)))) + (parent-channel (cc:signal-channel "parent")) + (channel (cc:signal-channel "child" parent-channel))) + + (cc:signal-connect parent-channel 'pev1 + (lambda (event) + (push (cons 'psig event) result))) + (cc:signal-connect parent-channel t + (lambda (event) + (push (cons 'pls event) result))) + (cc:signal-connect channel 'ev1 + (lambda (event) + (push (cons 'sig event) result))) + (cc:signal-connect channel t + (lambda (event) + (push (cons 'ls event) result))) + (deferred:$ + (cc:signal-connect channel 'ev1) + (deferred:nextc it + (lambda (x) + (push (cons 'def x) result)))) + + (deferred:$ + (deferred:next + (lambda (x) + (cc:signal-send parent-channel 'pev1 1) + (cc:signal-send parent-channel 'ev1 2) + (cc:signal-send channel 'ev1 3) + (cc:signal-send parent-channel 'ev2 4) + (cc:signal-send-global channel 'ev2 5))) + (deferred:nextc it + (lambda (x) (deferred:wait 300))) + (deferred:nextc it + (lambda (x) + (deferred:callback-post dfinish)))) + + dfinish)) + +;; (cc:debug (cc:test-signal2) "Signal2 : %s" x) + +(defvar cc:test-finished-flag nil) +(defvar cc:test-fails 0) + +(defun cc:test-all () + (interactive) + (setq cc:test-finished-flag nil) + (setq cc:test-fails 0) + (deferred:$ + (deferred:parallel + (loop for i in '(cc:test-fib-gen + cc:test-thread + cc:test-semaphore1 + cc:test-semaphore2 + cc:test-dataflow-simple1 + cc:test-dataflow-simple2 + cc:test-dataflow-simple3 + cc:test-dataflow-simple4 + cc:test-dataflow-signal + cc:test-dataflow-parent1 + cc:test-dataflow-parent2 + cc:test-signal1 + cc:test-signal2 + ) + collect (cons i (deferred:timeout 5000 "timeout" (funcall i))))) + (deferred:nextc it + (lambda (results) + (pop-to-buffer + (with-current-buffer (get-buffer-create "*cc:test*") + (erase-buffer) + (loop for i in results + for name = (car i) + for result = (cdr i) + with fails = 0 + do (insert (format "%s : %s\n" name + (if (eq t result) "OK" + (format "FAIL > %s" result)))) + (unless (eq t result) (incf fails)) + finally + (goto-char (point-min)) + (insert (format "Test Finished : %s\nTests Fails: %s / %s\n" + (format-time-string "%Y/%m/%d %H:%M:%S" (current-time)) + fails (length results))) + (setq cc:test-fails fails)) + (message (buffer-string)) + (current-buffer))) + (setq cc:test-finished-flag t)))) + + (while (null cc:test-finished-flag) + (sleep-for 0 100) (sit-for 0 100)) + (when (and noninteractive + (> cc:test-fails 0)) + (error "Test failed"))) + +(ert-deftest concurrent-all-the-thing () + (should-not (cc:test-all))) diff --git a/test/deferred-test.el b/test/deferred-test.el new file mode 100644 index 0000000..bba556e --- /dev/null +++ b/test/deferred-test.el @@ -0,0 +1,1021 @@ +;;; test code for deferred.el + +;; Copyright (C) 2010, 2011 SAKURAI Masashi +;; Author: SAKURAI Masashi + +;; 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 . + +;;; Commentary: + +;; Run tests: +;; $ emacs -batch -l test-deferred.el -f ert-run-tests-batch-and-exit + + +(require 'ert) +(require 'undercover) +(undercover "deferred.el" + (:send-report nil) + (:report-file "/tmp/undercover-report.json")) +(require 'deferred) +(require 'cl) +(require 'pp) + +(defmacro should= (a &rest b) + `(should (equal ,a (progn ,@b))) + ) + +(defmacro aand (test &rest rest) + `(let ((it ,test)) + (if it ,(if rest (macroexpand-all `(aand ,@rest)) 'it)))) + +(defmacro $ (&rest elements) + `(let (it) + ,@(loop for i in elements + with it = nil + collect + `(setq it ,i)) + it)) + +(defmacro dnew(&rest aforms) + (if aforms + `(deferred:new (lambda (x) ,@aforms)) + `(deferred:new))) + +(defmacro next(&rest aforms) + `(deferred:next (lambda (x) ,@aforms))) + +(defmacro nextc(d &rest aforms) + `(deferred:nextc ,d (lambda (x) ,@aforms))) + +(defmacro errorc(d &rest aforms) + `(deferred:error ,d (lambda (e) ,@aforms))) + +(defmacro errorf(d formatstr) + `(deferred:error ,d (lambda (e) (error ,formatstr e)))) + +(defmacro cancelc(d) + `(deferred:cancel ,d)) + +(defmacro wait(msec) + `(deferred:wait ,msec)) + +(defmacro dloop(&rest body) + `(deferred:loop ,@body)) + +(defmacro parallel(&rest args) + `(deferred:parallel ,@args)) + +(defmacro earlier(&rest args) + `(deferred:earlier ,@args)) + +(defmacro flush () + `(deferred:flush-queue!)) + +(defmacro clear () + `(setq deferred:queue nil)) + +(defmacro dtest (&rest form) + `(progn + (clear) + (lexical-let (last-value) + (nextc + ($ + ,@form) + (setq last-value x)) + (flush) + last-value))) + +(defmacro wtest (time &rest form) + `(progn + (clear) + (lexical-let (last-value) + (nextc + ($ + ,@form) + (setq last-value x)) + (while (null last-value) + (sit-for ,time)) + (flush) + last-value))) + +(defun deferred:setTimeout (f msec) + "overrided for test" + (deferred:call f)) + +(defun deferred:cancelTimeout (id) + "overrided for test" + (when (deferred-p id) + (deferred:cancel id))) + +(defun deferred:run-with-idle-timer (sec f) + "overrided for test" + (deferred:call f)) + +(defun deferred:not-called-func (&optional m) + (error "Must not be called!! %s" m)) + + + +(ert-deftest deferred-primitive-simple () + "> call-lambda simple" + (should= 1 (deferred:call-lambda (lambda () 1))) + (should= 1 (deferred:call-lambda (lambda () 1) 1)) + (should= 1 (deferred:call-lambda (lambda (x) 1))) + (should= 1 (deferred:call-lambda (lambda (x) 1) 1)) + (should= 1 (deferred:call-lambda (deferred:lambda () 1))) + (should= 1 (deferred:call-lambda (deferred:lambda () 1) 1)) + (should= nil (deferred:call-lambda 'car)) + (should= 2 (deferred:call-lambda 'car '(2 1))) + (should= nil (deferred:call-lambda (symbol-function 'car))) + (should= 2 (deferred:call-lambda (symbol-function 'car) '(2 1)))) + +(ert-deftest deferred-primitive-scope () + "> call-lambda lexical-scope" + (should= 3 (lexical-let ((st 1)) + (deferred:call-lambda + (lambda () (+ st 2))))) + (should= 3 (lexical-let ((st 1)) + (deferred:call-lambda + (lambda () (+ st 2)) 0))) + (should= 3 (lexical-let ((st 1)) + (deferred:call-lambda + (lambda (x) (+ st 2))))) + (should= 3 (lexical-let ((st 1)) + (deferred:call-lambda + (lambda (x) (+ st 2)) 0)))) + +(ert-deftest deferred-primitive-compile () + "> call-lambda byte-compile" + (should= 1 (deferred:call-lambda (byte-compile (lambda (x) 1)))) + (should= 1 (deferred:call-lambda (byte-compile (lambda (x) 1)) 1)) + (should= 1 (deferred:call-lambda (byte-compile (lambda () 1)))) + (should= 1 (deferred:call-lambda (byte-compile (lambda () 1)) 1)) + + (should= 3 (lexical-let ((st 1)) + (deferred:call-lambda + (byte-compile (lambda () (+ st 2)))))) + (should= 3 (lexical-let ((st 1)) ;ng + (deferred:call-lambda + (byte-compile (lambda () (+ st 2))) 0))) + (should= 3 (lexical-let ((st 1)) + (deferred:call-lambda + (byte-compile (lambda (x) (+ st 2)))))) + (should= 3 (lexical-let ((st 1)) ;ng + (deferred:call-lambda + (byte-compile (lambda (x) (+ st 2))) 0))) + + (should-error + (deferred:call-lambda + (lambda (x) (signal 'wrong-number-of-arguments '("org")))) + :type 'wrong-number-of-arguments)) + +(ert-deftest deferred-basic () + "Basic test for deferred functions." + (should (deferred-p + ;; function test + (deferred:new))) + (should (null + ;; basic cancel test + (let ((d (deferred:next 'deferred:not-called-func))) + (cancelc d) + (flush)))) + (should (deferred-p + ;; basic post function test + (progn + (clear) + (lexical-let ((d (dnew))) + (nextc d x) + (deferred:exec-task d 'ok "ok!"))))) + (should (deferred-p + ;; basic error post function test + (progn + (clear) + (lexical-let ((d (dnew))) + (deferred:error d (lambda (e) e)) + (deferred:exec-task d 'ng "error")))))) + +(ert-deftest deferred-basic-result-propagation () + "> result propagation" + (should= 'ok + ;; value saving test + (let ((d (deferred:succeed 1))) + (deferred:status d))) + + (should= 1 + ;; value saving test + (let ((d (deferred:succeed 1))) + (deferred-value d))) + + (should= nil + ;; value clearing test + (let ((d (deferred:succeed 1))) + (deferred:set-next d (dnew)) + (deferred:status d))) + + (should= 1 + ;; value propagating test + (let ((d (deferred:succeed 1)) + (nd (dnew))) + (deferred:set-next d nd) + (deferred-value nd)))) + +(ert-deftest deferred-basic-error-propagation () + "> error propagation" + (should= 'ok + ;; value saving test + (let ((d (deferred:succeed 1))) + (deferred:status d))) + + (should= 1 + ;; value saving test + (let ((d (deferred:succeed 1))) + (deferred-value d))) + + (should= nil + ;; value clearing test + (let ((d (deferred:succeed 1))) + (deferred:set-next d (dnew)) + (deferred:status d))) + + (should= 1 + ;; value propagating test + (let ((d (deferred:succeed 1)) + (nd (dnew))) + (deferred:set-next d nd) + (deferred-value nd)))) + +(ert-deftest deferred-main-chain () + ">>> Main Test / Chaining" + + (should= '(2 1 0) + ;; basic deferred chain test + (clear) + (lexical-let (vs) + ($ (next (push 1 vs)) + (nextc it (push 2 vs))) + (push 0 vs) + (flush) + vs)) + + (should= "errorback called" + ;; basic errorback test + (dtest (next (error "errorback")) + (errorc it (concat (cadr e) " called")))) + + (should= "next callback called" + ;; error recovery test + (dtest + (next (error "callback called")) + (errorc it (cadr e)) + (nextc it (concat "next " x)))) + + (should= '(error "second errorback called") + ;; error recovery test 2 + (dtest + (next (error "callback called")) + (nextc it (deferred:not-called-func "second errorback1")) + (errorc it e) + (errorc it (deferred:not-called-func "second errorback2")) + (nextc it (error "second errorback called")) + (nextc it "skipped") + (errorc it e))) + + (should= "start errorback ok1" + ;; start errorback test1 + (let (message-log-max) + (cl-letf (((symbol-function 'message) (lambda (&rest args) args))) + (let ((d (dnew))) + (dtest + (progn + (deferred:errorback d "start errorback") d) + (nextc it (deferred:not-called-func "ERROR : start errorback")) + (errorc it (cadr e)) + (nextc it (concat x " ok1"))))))) + + (should= "post errorback ok2" + ;; start errorback test1 + (let ((d (dnew))) + (dtest + (progn (deferred:errorback-post d "post errorback") d) + (nextc it (deferred:not-called-func "ERROR : post errorback")) + (errorc it (cadr e)) + (nextc it (concat x " ok2"))))) + + (should= "Child deferred chain" + ;; child deferred chain test + (dtest + (next + (next "Child deferred chain")) + (errorf it "Error on simple chain : %s"))) + + (should= "chain watch ok" + ;; watch chain: normal + (let ((val "><")) + (dtest + (next "chain") + (deferred:watch it + (lambda (x) (setq val " watch") nil)) + (nextc it (concat x val " ok"))))) + + (should= "error!! watch ok" + ;; watch chain: error + (let ((val "><")) + (dtest + (next "chain") + (nextc it (error "error!!")) + (deferred:watch it (lambda (x) (setq val " watch") nil)) + (errorc it (concat (cadr e) val " ok"))))) + + (should= "chain watch ok2" + ;; watch chain: normal + (let ((val "><")) + (dtest + (next "chain") + (deferred:watch it + (lambda (x) (error "ERROR"))) + (nextc it (concat x " watch ok2")))))) + +(ert-deftest deferred-async-connect () + "> async connect" + (should= "saved result!" + ;; asynchronously connect deferred and propagate a value + (let (d ret) + (clear) + (setq d (next "saved ")) + (deferred:callback d) + (flush) + (setq d (nextc d (concat x "result"))) + (nextc d (setq ret (concat x "!"))) + ret))) + +(ert-deftest deferred-global-onerror () + "> global onerror" + (should= "ONERROR" + ;; default onerror handler test + (lexical-let (ret) + (let ((deferred:onerror + (lambda (e) (setq ret (concat "ON" (error-message-string e)))))) + (dtest + (next (error "ERROR"))) + ret)))) + +(ert-deftest deferred-async-call () + "> async call" + (should= "ASYNC CALL" + ;; basic async 'call' test + (dtest + (deferred:call 'concat "ASYNC" " " "CALL"))) + + (should= "ASYNC APPLY" + ;; basic async 'apply' test + (dtest + (deferred:apply 'concat '("ASYNC" " " "APPLY"))))) + +(ert-deftest deferred-wait () + "> wait" + (should= "wait ok" + ;; basic wait test + (dtest + (wait 1) + (nextc it (if (< x 300) "wait ok" x)) + (errorf it "Error on simple wait : %s"))) + + (should= "waitc ok" + ;; wait chain test + (dtest + (wait 1) + (nextc it "wait") + (nextc it (wait 1)) + (nextc it (if (< x 300) "waitc ok" x)) + (errorf it "Error on simple wait chain : %s"))) + + (should= nil + ;; wait cancel test + (dtest + (wait 1000) + (cancelc it) + (nextc it (deferred:not-called-func "wait cancel")))) + + (should= "wait-idle ok" + ;; basic wait test + (dtest + (deferred:wait-idle 1) + (nextc it (if (< x 300) "wait-idle ok" x)) + (errorf it "Error on simple wait-idle : %s"))) + + (should= "wait-idlec ok" + ;; wait chain test + (dtest + (deferred:wait-idle 1) + (nextc it "wait") + (nextc it (deferred:wait-idle 1)) + (nextc it (if (< x 300) "wait-idlec ok" x)) + (errorf it "Error on simple wait-idle chain : %s"))) + + (should= nil + ;; wait cancel test + (dtest + (deferred:wait-idle 1000) + (cancelc it) + (nextc it (deferred:not-called-func "wait-idle cancel"))))) + +(ert-deftest deferred-sync-connect () + "> synchronized connection and wait a value" + (should= "sync connect1" + ;; real time connection1 + (dtest + (deferred:succeed "sync ") + (nextc it + (concat x "connect1")))) + + (should= "sync connect11" + ;; real time connection11 + (dtest + (deferred:succeed "sync ") + (nextc it + (concat x "connect1")) + (nextc it + (concat x "1")))) + + (should= "connect2" + ;; real time connection1 + (dtest + (deferred:succeed "sync ") + (nextc it + (next "connect")) + (nextc it + (concat x "2")))) + + (should= "connect!! GO" + ;; real time connection2 + (dtest + (deferred:succeed "sync ") + (nextc it + ($ + (next "connect") + (nextc it (concat x "!!")))) + (nextc it + (concat x " GO"))))) + +(ert-deftest deferred-try () + "> try-catch-finally" + + (should= "try" + ;; try block + (dtest + (deferred:try + (next "try")))) + + (should= "try" + ;; try catch block + (dtest + (deferred:try + (next "try") + :catch + (lambda (e) (concat "CATCH:" e))))) + + (should= "try-finally" + ;; try catch finally block + (let (val) + (dtest + (deferred:try + (next "try") + :finally + (lambda (x) (setq val "finally"))) + (nextc it (concat x "-" val))))) + + (should= "try-finally2" + ;; try catch finally block + (let (val) + (dtest + (deferred:try + (next "try") + :catch + (lambda (e) (concat "CATCH:" e)) + :finally + (lambda (x) (setq val "finally2"))) + (nextc it (concat x "-" val))))) + + (should= "try-catch:err" + ;; try block + (dtest + (deferred:try + ($ (next "start") + (nextc it (error "err")) + (nextc it (deferred:not-called-func x))) + :catch + (lambda (e) (concat "catch:" (cadr e)))) + (nextc it (concat "try-" x)))) + + (should= "try-catch:err-finally" + ;; try catch finally block + (let (val) + (dtest + (deferred:try + ($ (next "start") + (nextc it (error "err")) + (nextc it (deferred:not-called-func x))) + :catch + (lambda (e) (concat "catch:" (cadr e))) + :finally + (lambda (x) (setq val "finally"))) + (nextc it (concat "try-" x "-" val)))))) + + + +(ert-deftest deferred-loop () + "> loop" + (should= 10 + ;; basic loop test + (lexical-let ((v 0)) + (dtest + (dloop 5 (lambda (i) (setq v (+ v i)))) + (errorf it "Error on simple loop calling : %s")) + v)) + + (should= "loop ok 4" + ;; return value for a loop + (dtest + (dloop 5 (lambda (i) i)) + (nextc it (format "loop ok %i" x)) + (errorf it "Error on simple loop calling : %s"))) + + (should= "nested loop ok (4 nil 3 2 1 0)" + ;; nested deferred task in a loop + (lexical-let (count) + (dtest + (dloop 5 (lambda (i) + (push i count) + (if (eql i 3) (next (push x count))))) + (nextc it (format "nested loop ok %s" count)) + (errorf it "Error on simple loop calling : %s")) + ) + ) + + (should= '(6 4 2) + ;; do-loop test + (lexical-let (count) + (dtest + (dloop '(1 2 3) + (lambda (x) (push (* 2 x) count))) + (errorf it "Error on do-loop calling : %s")))) + + (should= nil + ;; zero times loop test + (dtest + (dloop 0 (lambda (i) (deferred:not-called-func "zero loop"))))) + + (should= nil + ;; loop cancel test + (dtest + (dloop 3 (lambda (i) (deferred:not-called-func "loop cancel"))) + (cancelc it))) + + (should= "loop error!" + ;; loop error recover test + (dtest + (deferred:loop 5 + (lambda (i) (if (= 2 i) (error "loop error")))) + (nextc it (deferred:not-called-func)) + (errorc it (format "%s!" (cadr e))) + (nextc it x))) + + (should= "loop error catch ok" + ;; try catch finally test + (lexical-let ((body (lambda () + (deferred:loop 5 + (lambda (i) (if (= 2 i) (error "loop error"))))))) + (dtest + (next "try ") ; try + (nextc it (funcall body)) ; body + (errorc it (format "%s catch " (cadr e))) ; catch + (nextc it (concat x "ok"))))) ; finally + + (should= "4 ok" + ;; try catch finally test + (lexical-let ((body (lambda () + (deferred:loop 5 + (lambda (i) i))))) + (dtest + (next "try ") ; try + (nextc it (funcall body)) ; body + (errorc it (format "%s catch " e)) ; catch + (nextc it (format "%s ok" x))))) ; finally + ) + + + +(ert-deftest deferred-parallel () + "> parallel" + (should= nil + ;; nil test + (dtest + (parallel '()))) + + (should= '(1) + ;; single job test: argument + (dtest + (parallel + (next 1)))) + + (should= '(1) + ;; single job test: function + (dtest + (parallel + (lambda () 1)))) + + (should= '(1) + ;; single job test: list + (dtest + (parallel + (list (next 1))))) + + (should= '((a . 1)) + ;; single job test: alist + (dtest + (parallel + (list (cons 'a (next 1)))))) + + (should= '(0 1) + ;; simple parallel test: just return value + (dtest + (parallel + (next 0) (next 1)))) + + (should= '(13 14) + ;; simple parallel test: list + (dtest + (parallel + (list (next 13) + (next 14))))) + + (should= '((a . 20) (b . 30)) + ;; simple parallel test: alist + (dtest + (parallel + (list (cons 'a (next 20)) + (cons 'b (next 30)))))) + + (should= '(0 1) + ;; simple parallel test: function list + (dtest + (parallel + (lambda () 0) (lambda () 1)))) + + (should= '(0 1) + ;; nested deferred and order change test + (dtest + (parallel + (lambda () (next 0)) + (next 1)))) + + (should= "((error ERROR) OK (error ERROR2))" + ;; error handling + (dtest + (parallel + (next (error "ERROR")) (next "OK") (next (error "ERROR2"))) + (nextc it (format "%s" x)))) + + (should= "((error ERROR) (error ERROR2))" + ;; failed test + (dtest + (parallel + (next (error "ERROR")) (next (error "ERROR2"))) + (nextc it (format "%s" x)))) + + (should= "((b . OK) (a error ERROR) (c error ERROR2))" + ;; error handling + (dtest + (parallel + (cons 'a (next (error "ERROR"))) + (cons 'b (next "OK")) + (cons 'c (next (error "ERROR2")))) + (nextc it (format "%s" x)))) + + (should= "((a error ERROR) (b error ERROR2))" + ;; failed test + (dtest + (parallel + (cons 'a (next (error "ERROR"))) + (cons 'b (next (error "ERROR2")))) + (nextc it (format "%s" x)))) + + (should= nil + ;; parallel cancel test + (dtest + (parallel + (list (next (deferred:not-called-func "parallel 1")) + (next (deferred:not-called-func "parallel 2")))) + (cancelc it))) + + (should= "nest parallel ok" + ;; parallel next + (lexical-let* ((flow (lambda (x) + (parallel + (next "nest ") + (next "parallel "))))) + (dtest + (next "start ") + (nextc it (funcall flow x)) + (nextc it (apply 'concat x)) + (nextc it (concat x "ok"))))) + + (should= "arrived (1) ok" + ;; arrived one deferred + (dtest + (parallel (deferred:succeed 1)) + (nextc it (format "arrived %s ok" x)))) + + (should= "arrived (1 2) ok" + ;; arrived deferreds + (dtest + (parallel (deferred:succeed 1) (deferred:succeed 2)) + (nextc it (format "arrived %s ok" x))))) + + + +(ert-deftest deferred-earlier () + "> earlier" + (should= nil + ;; nil test + (dtest + (earlier '()))) + + (should= 1 + ;; single job test: argument + (dtest + (earlier + (nextc (wait 10) 1)) + (nextc it x))) + + (should= 1 + ;; single job test: function + (dtest + (earlier + (lambda () 1)) + (nextc it x))) + + (should= 1 + ;; single job test: list + (dtest + (earlier + (list (next 1))) + (nextc it x))) + + (should= '(a . 1) + ;; single job test: alist + (dtest + (earlier + (list (cons 'a (next 1)))) + (nextc it x))) + + (should= '0 + ;; simple earlier test + (dtest + (earlier + (next 0) (next 1)) + (nextc it x))) + + (should= '11 + ;; simple earlier test: argument + (dtest + (earlier + (next 11) (next 12)) + (nextc it x))) + + (should= '13 + ;; simple earlier test: list + (dtest + (earlier + (list (next 13) (next 14))) + (nextc it x))) + + (should= '(a . 20) + ;; simple earlier test: alist + (dtest + (earlier + (list (cons 'a (next 20)) + (cons 'b (next 30)))) + (nextc it x))) + + (should= '0 + ;; simple earlier test: function list + (dtest + (earlier + (lambda () 0) (lambda () 1)) + (nextc it x))) + + (should= '1 + ;; nested deferred and order change test + (dtest + (earlier + (lambda () (dnew 0)) + (next 1)))) + + (should= "OK" + ;; error handling + (dtest + (earlier + (next (error "ERROR")) (next "OK") (next (error "ERROR2"))) + (nextc it x))) + + (should= nil + ;; failed test + (dtest + (earlier + (next (error "ERROR")) (next (error "ERROR2"))) + (nextc it x))) + + (should= '(b . "OK") + ;; error handling + (dtest + (earlier + (cons 'a (next (error "ERROR"))) + (cons 'b (next "OK")) + (cons 'c (next (error "ERROR2")))) + (nextc it x))) + + (should= nil + ;; failed test + (dtest + (earlier + (cons 'a (next (error "ERROR"))) + (cons 'b (next (error "ERROR2")))) + (nextc it x))) + + (should= nil + ;; cancel test + (dtest + (earlier + (list (next (deferred:not-called-func "earlier 1")) + (next (deferred:not-called-func "earlier 2")))) + (cancelc it))) + + (should= "arrived 1 ok" + ;; arrived one deferred + (dtest + (earlier (deferred:succeed 1)) + (nextc it (format "arrived %s ok" x)))) + + (should= "arrived 1 ok" + ;; arrived deferreds + (dtest + (earlier (deferred:succeed 1) (deferred:succeed 2)) + (nextc it (format "arrived %s ok" x))))) + +(ert-deftest deferred-sync! () + (should= "foo" + (deferred:$ + (deferred:next + (lambda () + "foo")) + (deferred:sync! it)))) + +;; process + +(ert-deftest deferred-process () + "> Process" + (should= + (with-temp-buffer + (call-process "pwd" nil t nil) + (buffer-string)) + (wtest 0.1 ;; maybe fail in some environments... + (deferred:process "pwd"))) + + (should= + (with-temp-buffer + (call-process "pwd" nil t nil) + (buffer-string)) + (wtest 0.1 ;; maybe fail in some environments... + (deferred:process "pwd" nil))) + + (should= + (length (buffer-list)) + (deferred:cancel (deferred:process "pwd" nil)) + (length (buffer-list))) + + (should= 0 + (dtest + (deferred:process "pwd---") + (nextc it (deferred:not-called-func)) + (errorc it (string-match "^Searching for program" (cadr e))))) + + (should= + (with-temp-buffer (call-process "pwd" nil t nil) + (buffer-string)) + (wtest 0.1 + (wait 0.1) + (deferred:processc it "pwd" nil))) + + (should= + (with-temp-buffer + (call-process "ls" nil t "-1") + (buffer-string)) + (wtest 0.1 ;; maybe fail in some environments... + (deferred:process-buffer "ls" "-1") + (nextc it + (unless (buffer-live-p x) + (error "Not live buffer : %s" x)) + (with-current-buffer x (buffer-string))))) + + (should= + (with-temp-buffer + (call-process "ls" nil t "-1") + (buffer-string)) + (wtest 0.1 ;; maybe fail in some environments... + (wait 0.1) + (deferred:process-bufferc it "ls" "-1") + (nextc it + (unless (buffer-live-p x) + (error "Not live buffer : %s" x)) + (with-current-buffer x (buffer-string))))) + + (should= + (length (buffer-list)) + (deferred:cancel (deferred:process-buffer "ls" nil)) + (length (buffer-list))) + + (should= 0 + (dtest + (deferred:process-buffer "pwd---") + (nextc it (deferred:not-called-func)) + (errorc it (string-match "^Searching for program" (cadr e))))) + + ;;shell + + (should= + (with-temp-buffer + (call-process-shell-command "pwd" nil t nil) + (buffer-string)) + (wtest 0.1 ;; maybe fail in some environments... + (deferred:process-shell "pwd"))) + + (should= + (with-temp-buffer + (call-process-shell-command "pwd" nil t nil) + (buffer-string)) + (wtest 0.1 ;; maybe fail in some environments... + (deferred:process-shell "pwd" nil))) + + (should= + (length (buffer-list)) + (deferred:cancel (deferred:process-shell "pwd" nil)) + (length (buffer-list))) + + (should= "ERROR" + (wtest 0.1 + (deferred:process-shell "lsasfdsadf") + (nextc it (deferred:not-called-func)) + (errorc it "ERROR"))) + + (should= + (with-temp-buffer (call-process-shell-command "pwd" nil t nil) + (buffer-string)) + (wtest 0.1 + (wait 0.1) + (deferred:process-shellc it "pwd" nil))) + + (should= + (with-temp-buffer + (call-process-shell-command "ls" nil t "-1") + (buffer-string)) + (wtest 0.1 ;; maybe fail in some environments... + (deferred:process-shell-buffer "ls" "-1") + (nextc it + (unless (buffer-live-p x) + (error "Not live buffer : %s" x)) + (with-current-buffer x (buffer-string))))) + + (should= + (with-temp-buffer + (call-process-shell-command "ls" nil t "-1") + (buffer-string)) + (wtest 0.1 ;; maybe fail in some environments... + (wait 0.1) + (deferred:process-shell-bufferc it "ls" "-1") + (nextc it + (unless (buffer-live-p x) + (error "Not live buffer : %s" x)) + (with-current-buffer x (buffer-string))))) + + (should= + (length (buffer-list)) + (deferred:cancel (deferred:process-shell-buffer "ls" nil)) + (length (buffer-list))) + + (should= "ERROR" + (wtest 0.1 + (deferred:process-shell-buffer "lssaf") + (nextc it (deferred:not-called-func)) + (errorc it "ERROR"))))