├── .ackrc ├── .gitignore ├── Cask ├── README.md ├── examples ├── promise-examples-jp.el └── promise-examples.el ├── promise-core.el ├── promise-done.el ├── promise-es6-extensions.el ├── promise-finally.el ├── promise-rejection-tracking.el ├── promise.el └── test ├── emacs-promise-test.el └── test-helper.el /.ackrc: -------------------------------------------------------------------------------- 1 | --ignore-dir=.cask/ 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.elc 2 | *.html 3 | .cask 4 | -------------------------------------------------------------------------------- /Cask: -------------------------------------------------------------------------------- 1 | (source gnu) 2 | (source melpa) 3 | 4 | (package-file "promise.el") 5 | 6 | (development 7 | (depends-on "f") 8 | (depends-on "ert") 9 | (depends-on "ert-async") 10 | (depends-on "ert-runner") 11 | (depends-on "ert-expectations")) 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Promises/A+ for Emacs 2 | ===================== 3 | 4 | This is a simple implementation of [Promises/A+](https://promisesaplus.com/). 5 | 6 | This implementation ported the following Promises/A+ implementation faithfully. 7 | https://github.com/then/promise 8 | 9 | * The same API as JavaScript version Promise can be used. 10 | * then, catch, resolve, reject, all, race, etc... 11 | * supports "thenable" 12 | * supports "Inheritance of Promise" 13 | * supports "rejection-tracking" 14 | 15 | For detailed tutorials on its use, see [www.promisejs.org](http://www.promisejs.org/) (JavaScript). 16 | 17 | *Promises/A+ for Emacs* is used in [Async/Await for Emacs](https://github.com/chuntaro/emacs-async-await), so you can use Async/Await for asynchronous programming. 18 | 19 | Installation 20 | ------------ 21 | 22 | You can install from MELPA using package.el. 23 | The package name is **promise**. 24 | 25 | Usage 26 | ----- 27 | 28 | See [promise-examples.el](https://github.com/chuntaro/emacs-promise/blob/master/examples/promise-examples.el) for details. 29 | 30 | 31 | ```emacs-lisp 32 | (require 'promise) 33 | 34 | (defun do-something-async (delay-sec value) 35 | "Return `Promise' to resolve the value asynchronously." 36 | (promise-new (lambda (resolve _reject) 37 | (run-at-time delay-sec 38 | nil 39 | (lambda () 40 | (funcall resolve value)))))) 41 | 42 | (defun example4 () 43 | "All processes are asynchronous Promise chain." 44 | (promise-chain (do-something-async 1 33) 45 | (then (lambda (result) 46 | (message "first result: %s" result) 47 | (do-something-async 1 (* result 2)))) 48 | 49 | (then (lambda (second-result) 50 | (message "second result: %s" second-result) 51 | (do-something-async 1 (* second-result 2)))) 52 | 53 | (then (lambda (third-result) 54 | (message "third result: %s" third-result))))) 55 | ``` 56 | 57 | An example using `url-retrieve 'as a more complicated example. 58 | 59 | ```emacs-lisp 60 | (require 'promise) 61 | (require 'url-http) 62 | (require 'xml) 63 | (require 'dom) 64 | 65 | (defun xml-retrieve (url) 66 | "Return `Promise' to resolve with XML object obtained by HTTP request." 67 | (promise-new 68 | (lambda (resolve reject) 69 | (url-retrieve url 70 | (lambda (status) 71 | ;; All errors are reliably captured and rejected with appropriate values. 72 | (if (plist-get status :error) 73 | (funcall reject (plist-get status :error)) 74 | (condition-case ex 75 | (with-current-buffer (current-buffer) 76 | (if (not (url-http-parse-headers)) 77 | (funcall reject (buffer-string)) 78 | (search-forward-regexp "\n\\s-*\n" nil t) 79 | (funcall resolve (xml-parse-region)))) 80 | (error (funcall reject ex))))))))) 81 | 82 | (defun get-text-first-tag (xml tag) 83 | "Returns the first text that matches TAG in XML." 84 | (decode-coding-string (dom-text (cl-first (dom-by-tag xml tag))) 85 | 'utf-8)) 86 | 87 | (defun get-short-text-first-tag (xml tag) 88 | "Truncate the text obtained with `get-text-first-tag'." 89 | (concat (truncate-string-to-width (get-text-first-tag xml tag) 64) 90 | " ...")) 91 | 92 | (defun wait-seconds (seconds fn &rest args) 93 | "Return `Promise' to execute the function after the specified time." 94 | (promise-new (lambda (resolve _reject) 95 | (run-at-time seconds 96 | nil 97 | (lambda () 98 | (funcall resolve (apply fn args))))))) 99 | 100 | (defun example12 () 101 | "Example using `xml-retrieve'." 102 | (let ((wikipedia-url (concat "https://en.wikipedia.org/w/api.php" 103 | "?format=xml&action=query&prop=extracts" 104 | "&exintro=&explaintext=&titles="))) 105 | (promise-chain (promise-all 106 | (vector 107 | (xml-retrieve (concat wikipedia-url (url-encode-url "GNU"))) 108 | ;; Request after 2 seconds for load reduction. 109 | (wait-seconds 2 110 | #'xml-retrieve 111 | (concat wikipedia-url (url-encode-url "Emacs"))))) 112 | (then (lambda (xmls) 113 | (message "%s" (get-short-text-first-tag (aref xmls 0) 'extract)) 114 | (message "%s" (get-short-text-first-tag (aref xmls 1) 'extract)))) 115 | 116 | (promise-catch (lambda (reason) 117 | (message "promise-catch: %s" reason)))))) 118 | ``` 119 | 120 | Tests 121 | ----- 122 | 123 | ``` 124 | $ cask install 125 | $ cask exec ert-runner 126 | ``` 127 | -------------------------------------------------------------------------------- /examples/promise-examples-jp.el: -------------------------------------------------------------------------------- 1 | ;;; promise-examples-jp.el --- Examples using `promise.el' for Japanese. -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2017 chuntaro 4 | 5 | ;; Author: chuntaro 6 | ;; URL: https://github.com/chuntaro/emacs-promise 7 | ;; Package-Requires: ((emacs "25")) 8 | ;; Version: 1.0 9 | ;; Keywords: convenience 10 | 11 | ;; This program is free software; you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation, either version 3 of the License, or 14 | ;; (at your option) any later version. 15 | 16 | ;; This program is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with this program. If not, see . 23 | 24 | ;;; Commentary: 25 | 26 | ;; This file is examples using `promise.el' for Japanese. 27 | ;; 28 | ;; このファイルは `promise-core.el' `promise-es6-extensions.el' で公開してる 29 | ;; 関数を全て使用した実践的な(だが実用的ではない…)サンプルコードです。 30 | ;; 31 | ;; 処理の内容は概ね以下の通りです。 32 | ;; 1. HTTP リクエスト(以降省略)で郵便番号(103-0000)から都道府県コードを取得する 33 | ;; 2. 都道府県コードから路線コードを取得する 34 | ;; 3. 路線コードから駅名一覧を取得する 35 | ;; 4. 駅名から Wikipedia と国立国会図書館の両方へ同時にサーチする 36 | ;; 37 | ;; 実際にはそれぞれの処理間にウェイトを入れたりタイムアウトを設定したりしています。 38 | ;; 39 | ;; `Promise' を使うと非同期処理をサブルーチン化したり、処理の内容をシンプルに 40 | ;; 書き下す事が出来るようになります。 41 | ;; (main) 内のコードを見て、上から下へ普通に書いてある何の変哲もないコードに 42 | ;; 見える事が `Promise' を使う目的です。 43 | ;; 44 | ;; 実行する場合は以下の Lisp コードの最後の括弧の後ろにポイントを移動して 45 | ;; C-x C-e と押してください。(新しい Emacs を起動して (main) を実行します) 46 | ;; 47 | ;; (start-process "emacs" nil (file-truename (expand-file-name invocation-name invocation-directory)) "-Q" "-f" "package-initialize" "-L" (concat default-directory "../") "-l" (buffer-file-name) "-f" "main") 48 | 49 | ;;; Code: 50 | 51 | (require 'promise) 52 | (require 'url-http) 53 | (require 'xml) 54 | (require 'dom) 55 | 56 | (defun wait-2sec (value) 57 | "2秒間ウェイトする `Promise' を返す。" 58 | (promise-new 59 | (lambda (resolve _reject) 60 | (let ((time 2.0)) 61 | (run-at-time time nil (lambda () 62 | (message "\nwait complete: %s sec" time) 63 | (funcall resolve value))))))) 64 | 65 | (defun timeout (time) 66 | "指定時間後にタイムアウトする `Promise' を返す。" 67 | (promise-new 68 | (lambda (_resolve reject) 69 | (run-at-time time nil (lambda () 70 | (funcall reject (format "timeout: %s" time))))))) 71 | 72 | (defun xml-retrieve (url) 73 | "HTTP リクエストして取得した XML オブジェクトで `resolve' する `Promise' を返す。" 74 | (promise-new 75 | (lambda (resolve reject) 76 | (url-retrieve url 77 | (lambda (status) 78 | ;; エラーは全て確実に捕捉して適切な値で `reject' する 79 | (if (plist-get status :error) 80 | (funcall reject (plist-get status :error)) 81 | (condition-case ex 82 | (if (not (url-http-parse-headers)) 83 | (funcall reject (buffer-string)) 84 | (search-forward-regexp "\n\\s-*\n" nil t) 85 | (funcall resolve (xml-parse-region))) 86 | (error (funcall reject ex))))))))) 87 | 88 | (defun get-first-attribute (xml tag attribute) 89 | "XML 内の TAG と ATTR にマッチした最初の値を返す。" 90 | (decode-coding-string (cl-reduce (lambda (a b) 91 | (or a (xml-get-attribute-or-nil b attribute))) 92 | (dom-by-tag xml tag) 93 | :initial-value nil) 94 | 'utf-8 t)) 95 | 96 | (defun get-state-code (state) 97 | "都道府県名から都道府県コードを返す。" 98 | (1+ (cl-position 99 | state 100 | ["北海道" "青森県" "岩手県" "宮城県" "秋田県" "山形県" "福島県" 101 | "茨城県" "栃木県" "群馬県" "埼玉県" "千葉県" "東京都" "神奈川県" 102 | "新潟県" "富山県" "石川県" "福井県" "山梨県" "長野県" "岐阜県" 103 | "静岡県" "愛知県" "三重県" "滋賀県" "京都府" "大阪府" "兵庫県" 104 | "奈良県" "和歌山県" "鳥取県" "島根県" "岡山県" "広島県" "山口県" 105 | "徳島県" "香川県" "愛媛県" "高知県" "福岡県" "佐賀県" "長崎県" 106 | "熊本県" "大分県" "宮崎県" "鹿児島県" "沖縄県"] 107 | :test #'string=))) 108 | 109 | (defun get-text-first-tag (xml tag) 110 | "XML 内の TAG にマッチした最初のテキストを返す。" 111 | (decode-coding-string (dom-text (car (dom-by-tag xml tag))) 112 | 'utf-8)) 113 | 114 | (defun main () 115 | (let ((postal-code "1030000") ; 〒103-0000 116 | station_name) 117 | 118 | ;; 出力を確認しやすくする為に `*Messages*' バッファを表示しておく 119 | (switch-to-buffer "*Messages*") 120 | 121 | ;; プロミスチェインを `xml-retrieve' から開始する 122 | (message "\n* 郵便番号(103-0000)から都道府県コードを取得する HTTP リクエスト") 123 | (promise-chain (xml-retrieve (concat "http://zip.cgis.biz/xml/zip.php?zn=" 124 | postal-code)) 125 | (then 126 | (lambda (xml) 127 | (let* ((state (get-first-attribute xml 'value 'state)) 128 | (city (get-first-attribute xml 'value 'city)) 129 | (state-code (get-state-code state))) 130 | (message " -> 都道府県コード: %s, 都道府県: %s, 市区町村: %s" 131 | state-code state city) 132 | ;; そのまま値を返すと次の `then' に渡される 133 | state-code))) 134 | 135 | ;; 次の `then' には HTTP リクエストがある為、ここで2秒間ウェイトする 136 | ;; もらった値はそのまま次の `then' に渡す 137 | (then #'wait-2sec) 138 | 139 | (then 140 | (lambda (state-code) 141 | (message "\n* 都道府県コードから路線コードを取得する HTTP リクエスト") 142 | ;; `promise-race' は渡された複数の `Promise' の内、最初に `resolve' された値を 143 | ;; 保持する `Promise' を返す 144 | ;; タイムアウトと一緒に使うのが典型的な使い方 145 | (promise-race 146 | (vector (timeout 10.0) 147 | (xml-retrieve 148 | (format "http://www.ekidata.jp/api/p/%d.xml" state-code)))))) 149 | 150 | (then 151 | (lambda (xml) 152 | (let ((line_cd (get-text-first-tag xml 'line_cd)) 153 | (line_name (get-text-first-tag xml 'line_name))) 154 | (message " -> 路線コード[0]: %s, 路線名[0]: %s" line_cd line_name) 155 | line_cd))) 156 | 157 | (then #'wait-2sec) 158 | 159 | (then 160 | (lambda (line_cd) 161 | (message "\n* 路線コードから駅名一覧を取得する HTTP リクエスト") 162 | (xml-retrieve (format "http://www.ekidata.jp/api/l/%s.xml" line_cd)))) 163 | 164 | (then 165 | (lambda (xml) 166 | (setf station_name (get-text-first-tag xml 'station_name)) 167 | (message " -> 駅名[0]: %s" station_name) 168 | station_name)) 169 | 170 | (then #'wait-2sec) 171 | 172 | (then 173 | (lambda (station_name) 174 | (message "\n* 駅名でWikipediaと国立国会図書館を同時にサーチする HTTP リクエスト") 175 | ;; `promise-all' は渡された複数の `Promise' の `resolve' された値を vector 内に 176 | ;; 全て保持する `Promise' を返す 177 | (promise-all 178 | (vector 179 | (xml-retrieve (concat "http://wikipedia.simpleapi.net/api?keyword=" 180 | (url-encode-url station_name))) 181 | (xml-retrieve (concat "http://iss.ndl.go.jp/api/opensearch?title=" 182 | (url-encode-url station_name))))))) 183 | 184 | (then 185 | (lambda (xml-vector) 186 | (let ((wikipedia (get-text-first-tag (aref xml-vector 0) 'body)) 187 | (title (get-text-first-tag (aref xml-vector 1) 'dc:title))) 188 | (message " -> Wikipedia: %s" wikipedia) 189 | (message " -> タイトル[0]: %s" title) 190 | title))) 191 | 192 | (then 193 | (lambda (title) 194 | ;; タイトルにはリクエストの度に駅名が含まれたり含まれなかったりする 195 | (if (string-match station_name title) 196 | (promise-resolve "完了!") 197 | (promise-reject "タイトルに駅名が含まれていない (⇒ エラーにする)")))) 198 | 199 | ;; この例では、全てのエラーは以下の `promise-catch' で捕捉する 200 | (promise-catch 201 | (lambda (reason) 202 | ;; (setf reason (/ 1 0)) ; コメントアウトをはずしてして確認すべし 203 | ;; ↑ここでエラー(0割り)が発生すると、後続の `done' で捕捉されるが、 204 | ;; 続く処理(この場合、message)は実行される事がない為、エラー処理内で 205 | ;; エラーが発生しないように気を付ける必要がある 206 | (message "promise-catch: %s" reason) 207 | "エラーで終了")) 208 | 209 | ;; `done' は内部や先行の処理でエラーが発生するとそのまま Emacs のエラーを 210 | ;; 発生させるので、最後に行なう処理は `done' に書くとエラーが飲み込まれる 211 | ;; 事がなくなる 212 | ;; 飲み込まれるとはどういう事かは、1つ上の0割りのコメントアウトをはずして 213 | ;; 以下の `done' を `then' に書き換えると確認出来る 214 | (done #'message)))) 215 | 216 | ;;; promise-examples-jp.el ends here 217 | -------------------------------------------------------------------------------- /examples/promise-examples.el: -------------------------------------------------------------------------------- 1 | ;;; promise-examples.el --- Examples using `promise.el'. -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2017 chuntaro 4 | 5 | ;; Author: chuntaro 6 | ;; URL: https://github.com/chuntaro/emacs-promise 7 | ;; Package-Requires: ((emacs "25") (async "1.9")) 8 | ;; Version: 1.0 9 | ;; Keywords: convenience 10 | 11 | ;; This program is free software; you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation, either version 3 of the License, or 14 | ;; (at your option) any later version. 15 | 16 | ;; This program is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with this program. If not, see . 23 | 24 | ;;; Commentary: 25 | 26 | ;; This file is examples using `promise.el'. 27 | ;; 28 | ;; To execute this, move the point after the last parenthesis of the following 29 | ;; Lisp code and press C-x C-e. (Launch the new Emacs and run (launcher)) 30 | ;; 31 | ;; (start-process "emacs" nil (file-truename (expand-file-name invocation-name invocation-directory)) "-Q" "-f" "package-initialize" "-L" (concat default-directory "../") "-l" (buffer-file-name) "-f" "launcher") 32 | 33 | ;;; Code: 34 | 35 | (require 'promise) 36 | (require 'url-http) 37 | (require 'xml) 38 | (require 'dom) 39 | 40 | (defun do-something () 41 | "Return `Promise' to resolve the value synchronously." 42 | (promise-new (lambda (resolve _reject) 43 | (let ((value 33)) 44 | (funcall resolve value))))) 45 | 46 | (defun example1 () 47 | "Resolved Promise keeps returning the same value." 48 | (let ((promise (do-something))) 49 | (promise-then promise 50 | (lambda (value) 51 | (message "Got a value: %s" value))) 52 | 53 | (promise-then promise 54 | (lambda (value) 55 | (message "Got the same value again: %s" value))))) 56 | 57 | (defun example2 () 58 | "Promise chain." 59 | (let ((promise (do-something))) 60 | (setf promise (promise-then promise 61 | (lambda (result) 62 | (message "first result: %s" result) 63 | 88))) 64 | 65 | (setf promise (promise-then promise 66 | (lambda (second-result) 67 | (message "second result: %s" second-result) 68 | 99))) 69 | 70 | (setf promise (promise-then promise 71 | (lambda (third-result) 72 | (message "third result: %s" third-result)))))) 73 | 74 | (defun example3 () 75 | "Same result as `example2'. 76 | `promise-chain' macro is a syntax sugar for easy writing." 77 | (promise-chain (do-something) 78 | (then (lambda (result) 79 | (message "first result: %s" result) 80 | 88)) 81 | 82 | (then (lambda (second-result) 83 | (message "second result: %s" second-result) 84 | 99)) 85 | 86 | (then (lambda (third-result) 87 | (message "third result: %s" third-result))))) 88 | 89 | (defun do-something-async (delay-sec value) 90 | "Return `Promise' to resolve the value asynchronously." 91 | (promise-new (lambda (resolve _reject) 92 | (run-at-time delay-sec 93 | nil 94 | (lambda () 95 | (funcall resolve value)))))) 96 | 97 | (defun example4 () 98 | "All processes are asynchronous Promise chain." 99 | (promise-chain (do-something-async 1 33) 100 | (then (lambda (result) 101 | (message "first result: %s" result) 102 | (do-something-async 1 (* result 2)))) 103 | 104 | (then (lambda (second-result) 105 | (message "second result: %s" second-result) 106 | (do-something-async 1 (* second-result 2)))) 107 | 108 | (then (lambda (third-result) 109 | (message "third result: %s" third-result))))) 110 | 111 | (defvar a-dummy) 112 | 113 | (defun example5 () 114 | "Catch the error." 115 | (promise-chain (do-something-async 1 33) 116 | (then (lambda (result) 117 | (message "first result: %s" result) 118 | (setf a-dummy (/ 1 0)))) ; An `(arith-error)' occurs here. 119 | 120 | (then (lambda (second-result) 121 | (message "second result: %s" second-result) 122 | (do-something-async 1 (* second-result 2))) 123 | (lambda (reason) 124 | (message "catch the error: %s" reason))))) 125 | 126 | (defun example6 () 127 | "Same result as `example5'." 128 | (promise-chain (do-something-async 1 33) 129 | (then (lambda (result) 130 | (message "first result: %s" result) 131 | (setf a-dummy (/ 1 0)))) ; An `(arith-error)' occurs here. 132 | 133 | (then nil 134 | (lambda (reason) 135 | (message "catch the error: %s" reason))))) 136 | 137 | (defun example7 () 138 | "Same result as `example6'. `promise-catch' is a syntax sugar." 139 | (promise-chain (do-something-async 1 33) 140 | (then (lambda (result) 141 | (message "first result: %s" result) 142 | (setf a-dummy (/ 1 0)))) ; An `(arith-error)' occurs here. 143 | 144 | (promise-catch (lambda (reason) 145 | (message "catch the error: %s" reason))))) 146 | 147 | (defun example8 () 148 | "How to use `promise-race'." 149 | (promise-chain (promise-race (vector (do-something-async 2 "2 seccods") 150 | (do-something-async 1 "1 second") 151 | (do-something-async 3 "3 secconds"))) 152 | (then (lambda (result) 153 | (message "result: %s" result))))) 154 | 155 | (defun timeout (time) 156 | "Return `Promise' which times out after the specified time." 157 | (promise-new (lambda (_resolve reject) 158 | (run-at-time time 159 | nil 160 | (lambda () 161 | (funcall reject "time out")))))) 162 | 163 | (defun example9 () 164 | "How to time out using `promise-race'." 165 | (promise-chain (promise-race (vector (timeout 2) 166 | (do-something-async 3 "3 seconds"))) 167 | (then (lambda (result) 168 | (message "result: %s" result))) 169 | 170 | (promise-catch (lambda (reason) 171 | (message "promise-catch: %s" reason))))) 172 | 173 | (defun example10 () 174 | "How to use `promise-all'." 175 | (promise-chain (promise-all (vector (do-something-async 2 "2 seccods") 176 | (do-something-async 1 "1 second") 177 | (do-something-async 3 "3 secconds"))) 178 | (then (lambda (results) 179 | (message "result[0]: %s" (aref results 0)) 180 | (message "result[1]: %s" (aref results 1)) 181 | (message "result[2]: %s" (aref results 2)))))) 182 | 183 | (defun do-randomthing-async () 184 | "Return `Promise' to resolve the random value asynchronously." 185 | (promise-new (lambda (resolve _reject) 186 | (run-at-time 1 187 | nil 188 | (lambda () 189 | (funcall resolve (random 100))))))) 190 | 191 | (defun example11 () 192 | "Branching to `resolve' or `reject' depending on the result." 193 | (promise-chain (do-randomthing-async) 194 | (then (lambda (result) 195 | (if (>= result 50) 196 | (promise-resolve (format "enough (%d >= 50)" result)) 197 | (promise-reject (format "short (%d < 50)" result))))) 198 | 199 | (then (lambda (result) 200 | (message "result: %s" result))) 201 | 202 | (promise-catch (lambda (reason) 203 | (message "promise-catch: %s" reason))))) 204 | 205 | ;; 206 | ;; Example using `url-retrieve' 207 | ;; 208 | 209 | (defun xml-retrieve (url) ; Same as `promise:xml-retrieve' 210 | "Return `Promise' to resolve with XML object obtained by HTTP request." 211 | (promise-new 212 | (lambda (resolve reject) 213 | (url-retrieve url 214 | (lambda (status) 215 | ;; All errors are reliably captured and rejected with appropriate values. 216 | (if (plist-get status :error) 217 | (funcall reject (plist-get status :error)) 218 | (condition-case ex 219 | (if (not (url-http-parse-headers)) 220 | (funcall reject (buffer-string)) 221 | (search-forward-regexp "\n\\s-*\n" nil t) 222 | (funcall resolve (xml-parse-region))) 223 | (error (funcall reject ex))))))))) 224 | 225 | (defun get-text-first-tag (xml tag) 226 | "Returns the first text that matches TAG in XML." 227 | (decode-coding-string (dom-text (cl-first (dom-by-tag xml tag))) 228 | 'utf-8)) 229 | 230 | (defun get-short-text-first-tag (xml tag) 231 | "Truncate the text obtained with `get-text-first-tag'." 232 | (concat (truncate-string-to-width (get-text-first-tag xml tag) 64) 233 | " ...")) 234 | 235 | (defun wait-seconds (seconds fn &rest args) ; Same as `promise:run-at-time' 236 | "Return `Promise' to execute the function after the specified time." 237 | (promise-new (lambda (resolve _reject) 238 | (run-at-time seconds 239 | nil 240 | (lambda () 241 | (funcall resolve (apply fn args))))))) 242 | 243 | (defun example12 () 244 | "Example using `xml-retrieve'." 245 | (let ((wikipedia-url (concat "https://en.wikipedia.org/w/api.php" 246 | "?format=xml&action=query&prop=extracts" 247 | "&exintro=&explaintext=&titles="))) 248 | (promise-chain (promise-all 249 | (vector 250 | (xml-retrieve (concat wikipedia-url (url-encode-url "GNU"))) 251 | ;; Request after 2 seconds for load reduction. 252 | (wait-seconds 2 253 | #'xml-retrieve 254 | (concat wikipedia-url (url-encode-url "Emacs"))))) 255 | (then (lambda (xmls) 256 | (message "%s" (get-short-text-first-tag (aref xmls 0) 'extract)) 257 | (message "%s" (get-short-text-first-tag (aref xmls 1) 'extract)))) 258 | 259 | (promise-catch (lambda (reason) 260 | (message "promise-catch: %s" reason)))))) 261 | 262 | ;; 263 | ;; Asynchronous Processes 264 | ;; 265 | 266 | (defun make-grep-process (&rest args) 267 | "Return Promise which invokes the process asynchronously 268 | and resolves it in the output result." 269 | (promise-new 270 | (lambda (resolve reject) 271 | (make-process :name "grep" 272 | :buffer "*grep-result*" 273 | :command (cl-list* "grep" args) 274 | :sentinel (lambda (_process event) 275 | (if (string= event "finished\n") 276 | (with-current-buffer "*grep-result*" 277 | (funcall resolve (buffer-string))) 278 | (funcall reject event))))))) 279 | 280 | (defun example13 () 281 | "An example using `make-process'." 282 | (promise-chain (make-grep-process "make-process" "promise-examples.el") 283 | (then (lambda (result) 284 | (message "grep result:\n%s" result))) 285 | 286 | (promise-catch (lambda (reason) 287 | (message "promise-catch: %s" reason))))) 288 | 289 | (defun example14 () 290 | "Same result as `example13'." 291 | (promise-chain (promise:make-process-string 292 | '("grep" "make-process" "promise-examples.el")) 293 | (then (lambda (result) 294 | (message "grep result:\n%s" result))) 295 | 296 | (catch (lambda (reason) 297 | (message "promise-catch: %s" reason))))) 298 | 299 | (defun example15 () 300 | "An example when `make-process' returns an error." 301 | (promise-chain (promise:make-process-string 302 | '("grep" "string not in source \\ " "promise-examples.el")) 303 | (then (lambda (result) 304 | (message "grep result:\n%s" result))) 305 | 306 | (promise-catch (lambda (reason) 307 | (message "promise-catch: %s" reason))))) 308 | 309 | (defun example16 () 310 | "Example using promise: async-start. 311 | Get the 30000th value of Fibonacci number." 312 | (promise-chain (promise:async-start (lambda () 313 | (require 'calc-ext) 314 | (defmath fibonacci (n) 315 | "Calculate n-th Fibonacci number." 316 | (let ((a 1) 317 | (b 0) 318 | c 319 | (k 2)) 320 | (while (<= k n) 321 | (setq c b 322 | b a 323 | a (+ b c) 324 | k (+ k 1))) 325 | a)) 326 | (calc-eval "fibonacci(30000)"))) 327 | (then (lambda (result) 328 | (message "fibonacci(30000) -> %s" result))))) 329 | 330 | ;; 331 | ;; Thenable 332 | ;; 333 | ;; This `emacs-promise' makes `thenable' an OBJECT whose `promise-then' is defined. 334 | ;; OBJECT must be created with `defstruct' or `defclass'. 335 | ;; 336 | 337 | (cl-defstruct thenable 338 | value) 339 | 340 | (cl-defmethod promise-then ((this thenable) &optional resolve reject) 341 | "The signature of this method must be the same." 342 | (run-at-time 1 nil (lambda () 343 | (if (thenable-value this) 344 | (funcall resolve (concat "[" (upcase (thenable-value this)) "]")) 345 | (funcall reject "failed: thenable"))))) 346 | 347 | (defun example17 () 348 | "Thenable must be passed to `promise-resolve'." 349 | (promise-chain (promise-resolve (make-thenable :value "This is `thenable'")) 350 | (then (lambda (result) 351 | (message "result: %s" result))) 352 | 353 | (promise-catch (lambda (reason) 354 | (message "promise-catch: %s" reason))))) 355 | 356 | ;; 357 | ;; Inheritance of Promise 358 | ;; 359 | 360 | (defclass simple-logger (promise-class) 361 | ((call-count :accessor call-count :initform 0)) 362 | :documentation "Record the number of times `promise-then' was called.") 363 | 364 | (cl-defmethod promise-then ((this simple-logger) &optional on-fulfilled on-rejected) 365 | (let ((new-promise ; `promise-then' always returns a new promise." 366 | (cl-call-next-method this 367 | (lambda (result) 368 | (message "%d: result: %s" 369 | (1+ (call-count this)) 370 | result) 371 | (funcall on-fulfilled result)) 372 | on-rejected))) 373 | (setf (call-count new-promise) (1+ (call-count this))) 374 | new-promise)) 375 | 376 | (defun example18 () 377 | (promise-chain (make-instance 'simple-logger 378 | :fn (lambda (resolve _reject) 379 | (let ((value 33)) 380 | (funcall resolve value)))) 381 | (then (lambda (result) 382 | (* result 2))) 383 | 384 | (then (lambda (second-result) 385 | (setf a-dummy (/ 1 0)) ; An `(arith-error)' occurs here. 386 | (* second-result 2))) 387 | 388 | (then (lambda (third-result) 389 | ;; Do not reach 390 | (message "third result: %s" third-result))) 391 | 392 | ;; In the `promise-chain', the `promise' variable is defined. 393 | (message "* type-of promise: %s" (promise--type-of promise)) 394 | (message "* `promise-then' total call count: %d" (call-count promise)))) 395 | 396 | ;; 397 | ;; Unhandled Rejections 398 | ;; 399 | 400 | (defun example19 () 401 | "An example where Promise swallows an error." 402 | (promise-chain (do-something-async 1 33) 403 | (then (lambda (result) 404 | (message "first result: %s" result) 405 | (setf a-dummy (/ 1 0)))) ; An `(arith-error)' occurs here. 406 | 407 | ;; Oops! I forgot to capture the error! 408 | ;; Nothing is displayed except for the first result. 409 | (then (lambda (second-result) 410 | (message "second result: %s" second-result))))) 411 | 412 | (require 'promise-rejection-tracking) 413 | 414 | (defun example20 () 415 | "Example of `rejection-tracking'." 416 | 417 | ;; Enable `rejection-tracking'. 418 | ;; The option should always specify (all-rejections . t). 419 | (promise-rejection-tracking-enable '((all-rejections . t))) 420 | ;; Since this has a penalty of execution speed, 421 | ;; it should be effective only during development. 422 | 423 | (promise-chain (do-something-async 1 33) 424 | (then (lambda (result) 425 | (message "first result: %s" result) 426 | (setf a-dummy (/ 1 0)))) ; An `(arith-error)' occurs here. 427 | 428 | ;; if rejection-tracking is enabled, 429 | ;; an error will be displayed in a few seconds! 430 | (then (lambda (second-result) 431 | (message "second result: %s" second-result))))) 432 | 433 | ;; 434 | ;; Launcher 435 | ;; 436 | 437 | (defun launcher () 438 | "A launcher that runs each example." 439 | (require 'ido) 440 | (switch-to-buffer "*Messages*") 441 | (setq inhibit-message t 442 | scroll-conservatively 10000) 443 | 444 | (let (nums) 445 | (mapatoms 446 | (lambda (x) 447 | (when (fboundp x) 448 | (let ((name (symbol-name x))) 449 | (when (string-match "^example\\([0-9]+\\)$" name) 450 | (push (match-string 1 name) nums)))))) 451 | (cl-callf cl-sort nums #'< :key #'string-to-number) 452 | (cl-loop 453 | (let* ((num (ido-completing-read "What number of examples do you run?: example" 454 | nums)) 455 | (example (intern (concat "example" num)))) 456 | (message "***** example%s *****" num) 457 | (funcall example))))) 458 | 459 | ;;; promise-examples.el ends here 460 | -------------------------------------------------------------------------------- /promise-core.el: -------------------------------------------------------------------------------- 1 | ;;; promise-core.el --- This is a simple implementation of Promises/A+. -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2017 chuntaro 4 | 5 | ;; Author: chuntaro 6 | ;; URL: https://github.com/chuntaro/emacs-promise 7 | ;; Keywords: async promise convenience 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License 20 | ;; along with this program. If not, see . 21 | 22 | ;; The original JavaScript code is: 23 | ;; 24 | ;; Copyright (c) 2014 Forbes Lindesay 25 | ;; 26 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 27 | ;; of this software and associated documentation files (the "Software"), to deal 28 | ;; in the Software without restriction, including without limitation the rights 29 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 30 | ;; copies of the Software, and to permit persons to whom the Software is 31 | ;; furnished to do so, subject to the following conditions: 32 | ;; 33 | ;; The above copyright notice and this permission notice shall be included in 34 | ;; all copies or substantial portions of the Software. 35 | ;; 36 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 37 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 38 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 39 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 40 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 41 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 42 | ;; THE SOFTWARE. 43 | 44 | ;;; Commentary: 45 | 46 | ;; This implementation ported the following Promises/A+ implementation faithfully. 47 | ;; https://github.com/then/promise/blob/master/src/core.js 48 | ;; 49 | ;; This file contains the core Promises/A+ API. 50 | ;; (promise-new fn) or (make-instance 'promise-class :fn fn) 51 | ;; (promise-then ((this promise-class) &optional on-fulfilled on-rejected)) 52 | 53 | ;;; Code: 54 | 55 | (require 'eieio) 56 | (require 'cl-lib) 57 | (eval-when-compile (require 'subr-x)) 58 | 59 | (defun promise--asap (task) 60 | (run-at-time 0.001 nil task)) 61 | 62 | (defun promise--type-of (obj) 63 | (cond 64 | ((not (vectorp obj)) 65 | (type-of obj)) 66 | ((cl-struct-p obj) 67 | ;; Code copied from `cl--describe-class'. 68 | (cl--class-name (symbol-value (aref obj 0)))) 69 | ((eieio-object-p obj) 70 | (eieio-object-class obj)) 71 | (t 72 | 'vector))) 73 | 74 | (defun promise--is-object (obj) 75 | (or (cl-struct-p obj) 76 | (eieio-object-p obj))) 77 | 78 | (defsubst promise--find-then-method (obj) 79 | (cl-find-method #'promise-then '() (list (promise--type-of obj)))) 80 | 81 | (defun promise--find-then-function (obj) 82 | (when-let (method (promise--find-then-method obj)) 83 | (cl--generic-method-function method))) 84 | 85 | ;; States: 86 | ;; 87 | ;; 0 - pending 88 | ;; 1 - fulfilled with _value 89 | ;; 2 - rejected with _value 90 | ;; 3 - adopted the state of another promise, _value 91 | ;; 92 | ;; once the state is no longer pending (0) it is immutable 93 | 94 | ;; to avoid using condition-case inside critical functions, we 95 | ;; extract them to here. 96 | (defvar promise--last-error nil) 97 | (defconst promise--is-error (cl-gensym "promise-error")) 98 | (defun promise--get-then (obj) 99 | (condition-case ex 100 | (promise--find-then-function obj) 101 | (error (setf promise--last-error ex) 102 | promise--is-error))) 103 | 104 | (defun promise--try-call-one (fn a) 105 | (condition-case ex 106 | (funcall fn a) 107 | (error (setf promise--last-error ex) 108 | promise--is-error))) 109 | 110 | (defun promise--try-call-two (fn a b) 111 | (condition-case ex 112 | (funcall fn a b) 113 | (error (setf promise--last-error ex) 114 | promise--is-error))) 115 | 116 | (defclass promise-class () 117 | ((_deferred-state :accessor promise-_deferred-state :initform 0) 118 | (_state :accessor promise-_state :initform 0) 119 | (_value :accessor promise-_value :initform nil) 120 | (_deferreds :accessor promise-_deferreds :initform nil) 121 | ;; for rejection-tracking 122 | (_rejection-id :accessor promise-_rejection-id :initform nil))) 123 | (defvar promise--on-handle nil) 124 | (defvar promise--on-reject nil) 125 | 126 | (cl-defmethod initialize-instance ((this promise-class) &optional args) 127 | (cl-call-next-method this) 128 | (let ((fn (plist-get args :fn))) 129 | (unless (eq fn #'ignore) 130 | (promise--do-resolve fn this)))) 131 | 132 | (defun promise-new (fn) 133 | (make-instance 'promise-class :fn fn)) 134 | 135 | (cl-defmethod promise-then ((this promise-class) &optional on-fulfilled on-rejected) 136 | (if (not (eq (promise--type-of this) 'promise-class)) 137 | (promise--safe-then this on-fulfilled on-rejected) 138 | (let ((res (promise-new #'ignore))) 139 | (promise--handle this 140 | (promise--handler-new on-fulfilled 141 | on-rejected 142 | res)) 143 | res))) 144 | 145 | (defun promise--safe-then (self on-fulfilled on-rejected) 146 | (make-instance (promise--type-of self) 147 | :fn (lambda (resolve reject) 148 | (let ((res (promise-new #'ignore))) 149 | (promise-then res resolve reject) 150 | (promise--handle self 151 | (promise--handler-new on-fulfilled 152 | on-rejected 153 | res)))))) 154 | 155 | (defun promise--handle (self deferred) 156 | (while (= (promise-_state self) 3) 157 | (setf self (promise-_value self))) 158 | (when promise--on-handle 159 | (funcall promise--on-handle self)) 160 | (if (= (promise-_state self) 0) 161 | (cond 162 | ((= (promise-_deferred-state self) 0) 163 | (setf (promise-_deferred-state self) 1 164 | (promise-_deferreds self) deferred)) 165 | ((= (promise-_deferred-state self) 1) 166 | (setf (promise-_deferred-state self) 2 167 | (promise-_deferreds self) (list (promise-_deferreds self) 168 | deferred))) 169 | (t 170 | (setf (promise-_deferreds self) (nconc (promise-_deferreds self) 171 | (list deferred))))) 172 | (promise--handle-resolved self deferred))) 173 | 174 | (defun promise--handle-resolved (self deferred) 175 | (promise--asap 176 | (lambda () 177 | (let-alist deferred 178 | (let ((cb (if (= (promise-_state self) 1) .on-fulfilled .on-rejected))) 179 | (if (not cb) 180 | (if (= (promise-_state self) 1) 181 | (promise--resolve .promise (promise-_value self)) 182 | (promise--reject .promise (promise-_value self))) 183 | (let ((ret (promise--try-call-one cb (promise-_value self)))) 184 | (if (eq ret promise--is-error) 185 | (promise--reject .promise promise--last-error) 186 | (promise--resolve .promise ret))))))))) 187 | 188 | (defun promise--resolve (self new-value) 189 | "Promise Resolution Procedure. 190 | See: https://github.com/promises-aplus/promises-spec#the-promise-resolution-procedure" 191 | (cl-block nil 192 | (when (eq new-value self) 193 | (cl-return (promise--reject 194 | self 195 | '(wrong-type-argument 196 | "A promise cannot be resolved with itself.")))) 197 | (when (and new-value 198 | (promise--is-object new-value)) 199 | (let ((then (promise--get-then new-value))) 200 | (when (eq then promise--is-error) 201 | (cl-return (promise--reject self promise--last-error))) 202 | (cond 203 | ((and (eq then (ignore-errors (promise--find-then-function self))) 204 | (promise-class-p new-value)) 205 | (setf (promise-_state self) 3 206 | (promise-_value self) new-value) 207 | (promise--finale self) 208 | (cl-return)) 209 | ((functionp then) 210 | (promise--do-resolve (lambda (resolve reject) 211 | (promise-then new-value resolve reject)) 212 | self) 213 | (cl-return))))) 214 | (setf (promise-_state self) 1 215 | (promise-_value self) new-value) 216 | (promise--finale self))) 217 | 218 | (defun promise--reject (self new-value) 219 | (setf (promise-_state self) 2 220 | (promise-_value self) new-value) 221 | (when promise--on-reject 222 | (funcall promise--on-reject self new-value)) 223 | (promise--finale self)) 224 | 225 | (defun promise--finale (self) 226 | (when (= (promise-_deferred-state self) 1) 227 | (promise--handle self (promise-_deferreds self)) 228 | (setf (promise-_deferreds self) nil)) 229 | (when (= (promise-_deferred-state self) 2) 230 | (dolist (deferred (promise-_deferreds self)) 231 | (promise--handle self deferred)) 232 | (setf (promise-_deferreds self) nil)) 233 | nil) 234 | 235 | (defun promise--handler-new (on-fulfilled on-rejected promise) 236 | `((on-fulfilled . ,(and (functionp on-fulfilled) on-fulfilled)) 237 | (on-rejected . ,(and (functionp on-rejected) on-rejected)) 238 | (promise . ,promise))) 239 | 240 | ;; Take a potentially misbehaving resolver function and make sure 241 | ;; onFulfilled and onRejected are only called once. 242 | ;; 243 | ;; Makes no guarantees about asynchrony. 244 | (defun promise--do-resolve (fn promise) 245 | (let* ((done nil) 246 | (res (promise--try-call-two 247 | fn 248 | (lambda (&optional value) 249 | (unless done 250 | (setf done t) 251 | (promise--resolve promise value))) 252 | (lambda (&optional reason) 253 | (unless done 254 | (setf done t) 255 | (promise--reject promise reason)))))) 256 | (when (and (not done) 257 | (eq res promise--is-error)) 258 | (setf done t) 259 | (promise--reject promise promise--last-error)))) 260 | 261 | (provide 'promise-core) 262 | ;;; promise-core.el ends here 263 | -------------------------------------------------------------------------------- /promise-done.el: -------------------------------------------------------------------------------- 1 | ;;; promise-done.el --- Porting done.js -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2017 chuntaro 4 | 5 | ;; Author: chuntaro 6 | ;; URL: https://github.com/chuntaro/emacs-promise 7 | ;; Keywords: async promise convenience 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License 20 | ;; along with this program. If not, see . 21 | 22 | ;; The original JavaScript code is: 23 | ;; 24 | ;; Copyright (c) 2014 Forbes Lindesay 25 | ;; 26 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 27 | ;; of this software and associated documentation files (the "Software"), to deal 28 | ;; in the Software without restriction, including without limitation the rights 29 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 30 | ;; copies of the Software, and to permit persons to whom the Software is 31 | ;; furnished to do so, subject to the following conditions: 32 | ;; 33 | ;; The above copyright notice and this permission notice shall be included in 34 | ;; all copies or substantial portions of the Software. 35 | ;; 36 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 37 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 38 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 39 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 40 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 41 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 42 | ;; THE SOFTWARE. 43 | 44 | ;;; Commentary: 45 | 46 | ;; This implementation ported the following implementation faithfully. 47 | ;; https://github.com/then/promise/blob/master/src/done.js 48 | 49 | ;;; Code: 50 | 51 | (require 'promise-core) 52 | 53 | (cl-defmethod promise-done ((this promise-class) &optional on-fulfilled on-rejected) 54 | (let ((self (if (or on-fulfilled on-rejected) 55 | (promise-then this on-fulfilled on-rejected) 56 | this))) 57 | (promise-then self nil (lambda (err) 58 | (run-at-time 0 nil 59 | (lambda () 60 | (signal 'error (list err))))))) 61 | nil) 62 | 63 | (provide 'promise-done) 64 | ;;; promise-done.el ends here 65 | -------------------------------------------------------------------------------- /promise-es6-extensions.el: -------------------------------------------------------------------------------- 1 | ;;; promise-es6-extensions.el --- Porting es6-extensions.js -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2017 chuntaro 4 | 5 | ;; Author: chuntaro 6 | ;; URL: https://github.com/chuntaro/emacs-promise 7 | ;; Keywords: async promise convenience 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License 20 | ;; along with this program. If not, see . 21 | 22 | ;; The original JavaScript code is: 23 | ;; 24 | ;; Copyright (c) 2014 Forbes Lindesay 25 | ;; 26 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 27 | ;; of this software and associated documentation files (the "Software"), to deal 28 | ;; in the Software without restriction, including without limitation the rights 29 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 30 | ;; copies of the Software, and to permit persons to whom the Software is 31 | ;; furnished to do so, subject to the following conditions: 32 | ;; 33 | ;; The above copyright notice and this permission notice shall be included in 34 | ;; all copies or substantial portions of the Software. 35 | ;; 36 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 37 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 38 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 39 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 40 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 41 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 42 | ;; THE SOFTWARE. 43 | 44 | ;;; Commentary: 45 | 46 | ;; This implementation ported the following implementation faithfully. 47 | ;; https://github.com/then/promise/blob/master/src/es6-extensions.js 48 | ;; 49 | ;; This file contains the ES6 extensions to the core Promises/A+ API. 50 | ;; (promise-resolve value) 51 | ;; (promise-all [values...]) 52 | ;; (promise-reject value) 53 | ;; (promise-race [values...]) 54 | ;; (promise-catch ((this promise-class) on-rejected)) 55 | 56 | ;;; Code: 57 | 58 | (require 'promise-core) 59 | 60 | (defsubst promise--then-function () 61 | (ignore-errors 62 | (cl--generic-method-function (cl-find-method #'promise-then 63 | '() 64 | '(promise-class))))) 65 | 66 | ;; Static Functions 67 | 68 | (defun promise--value (value) 69 | (let ((p (promise-new #'ignore))) 70 | (setf (promise-_state p) 1 71 | (promise-_value p) value) 72 | p)) 73 | 74 | (defconst promise-t (promise--value t)) 75 | (defconst promise-nil (promise--value nil)) 76 | (defconst promise-zero (promise--value 0)) 77 | (defconst promise-emptystring (promise--value "")) 78 | 79 | (defun promise-resolve (value) 80 | (cond 81 | ((promise-class-p value) value) 82 | 83 | ((eq value t) promise-t) 84 | ((eq value nil) promise-nil) 85 | ((eq value 0) promise-zero) 86 | ((eq value "") promise-emptystring) 87 | 88 | ((promise--is-object value) 89 | (condition-case ex 90 | (let ((then (ignore-errors (promise--find-then-function value)))) 91 | (if (functionp then) 92 | (promise-new (lambda (resolve reject) 93 | (promise-then value resolve reject))) 94 | (promise--value value))) 95 | (error (promise-new (lambda (_resolve reject) 96 | (funcall reject ex)))))) 97 | (t 98 | (promise--value value)))) 99 | 100 | (defun promise-all (arr) 101 | (let ((args (cl-coerce arr 'vector))) 102 | 103 | (promise-new 104 | (lambda (resolve reject) 105 | (if (zerop (length args)) 106 | (funcall resolve []) 107 | (let ((remaining (length args))) 108 | (cl-labels 109 | ((res (i val) 110 | (cl-block nil 111 | (when (and val (promise--is-object val)) 112 | (cond 113 | ((and (promise-class-p val) 114 | (eq (promise--find-then-function val) 115 | (promise--then-function))) 116 | (while (= (promise-_state val) 3) 117 | (setf val (promise-_value val))) 118 | (when (= (promise-_state val) 1) 119 | (cl-return (res i (promise-_value val)))) 120 | (when (= (promise-_state val) 2) 121 | (funcall reject (promise-_value val))) 122 | (promise-then val 123 | (lambda (val) 124 | (res i val)) 125 | reject) 126 | (cl-return)) 127 | (t 128 | (let ((then (ignore-errors 129 | (promise--find-then-function val)))) 130 | (when (functionp then) 131 | (let ((p (promise-new 132 | (lambda (resolve reject) 133 | (promise-then val 134 | resolve 135 | reject))))) 136 | (promise-then p 137 | (lambda (val) 138 | (res i val)) 139 | reject) 140 | (cl-return))))))) 141 | (setf (aref args i) val) 142 | (when (zerop (cl-decf remaining)) 143 | (funcall resolve args))))) 144 | (cl-loop for i from 0 145 | for arg across args 146 | do (res i arg))))))))) 147 | 148 | (defun promise-reject (value) 149 | (promise-new (lambda (_resolve reject) 150 | (funcall reject value)))) 151 | 152 | (defun promise-race (values) 153 | (promise-new (lambda (resolve reject) 154 | (cl-loop for value across (cl-coerce values 'vector) 155 | do (promise-then (promise-resolve value) 156 | resolve 157 | reject))))) 158 | 159 | (cl-defmethod promise-catch ((this promise-class) on-rejected) 160 | (promise-then this nil on-rejected)) 161 | 162 | (provide 'promise-es6-extensions) 163 | ;;; promise-es6-extensions.el ends here 164 | -------------------------------------------------------------------------------- /promise-finally.el: -------------------------------------------------------------------------------- 1 | ;;; promise-finally.el --- Porting finally.js -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2017 chuntaro 4 | 5 | ;; Author: chuntaro 6 | ;; URL: https://github.com/chuntaro/emacs-promise 7 | ;; Keywords: async promise convenience 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License 20 | ;; along with this program. If not, see . 21 | 22 | ;; The original JavaScript code is: 23 | ;; 24 | ;; Copyright (c) 2014 Forbes Lindesay 25 | ;; 26 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 27 | ;; of this software and associated documentation files (the "Software"), to deal 28 | ;; in the Software without restriction, including without limitation the rights 29 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 30 | ;; copies of the Software, and to permit persons to whom the Software is 31 | ;; furnished to do so, subject to the following conditions: 32 | ;; 33 | ;; The above copyright notice and this permission notice shall be included in 34 | ;; all copies or substantial portions of the Software. 35 | ;; 36 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 37 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 38 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 39 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 40 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 41 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 42 | ;; THE SOFTWARE. 43 | 44 | ;;; Commentary: 45 | 46 | ;; This implementation ported the following implementation faithfully. 47 | ;; https://github.com/then/promise/blob/master/src/finally.js 48 | 49 | ;;; Code: 50 | 51 | (require 'promise-es6-extensions) 52 | 53 | (cl-defmethod promise-finally ((this promise-class) f) 54 | (promise-then this 55 | (lambda (value) 56 | (promise-then (promise-resolve (funcall f)) 57 | (lambda (_) value))) 58 | (lambda (err) 59 | (promise-then (promise-resolve (funcall f)) 60 | (lambda (_) 61 | (promise-reject err)))))) 62 | 63 | (provide 'promise-finally) 64 | ;;; promise-finally.el ends here 65 | -------------------------------------------------------------------------------- /promise-rejection-tracking.el: -------------------------------------------------------------------------------- 1 | ;;; promise-rejection-tracking.el --- Porting rejection-tracking.js -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2017 chuntaro 4 | 5 | ;; Author: chuntaro 6 | ;; URL: https://github.com/chuntaro/emacs-promise 7 | ;; Keywords: async promise convenience 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License 20 | ;; along with this program. If not, see . 21 | 22 | ;; The original JavaScript code is: 23 | ;; 24 | ;; Copyright (c) 2014 Forbes Lindesay 25 | ;; 26 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 27 | ;; of this software and associated documentation files (the "Software"), to deal 28 | ;; in the Software without restriction, including without limitation the rights 29 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 30 | ;; copies of the Software, and to permit persons to whom the Software is 31 | ;; furnished to do so, subject to the following conditions: 32 | ;; 33 | ;; The above copyright notice and this permission notice shall be included in 34 | ;; all copies or substantial portions of the Software. 35 | ;; 36 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 37 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 38 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 39 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 40 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 41 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 42 | ;; THE SOFTWARE. 43 | 44 | ;;; Commentary: 45 | 46 | ;; This implementation ported the following implementation faithfully. 47 | ;; https://github.com/then/promise/blob/master/src/rejection-tracking.js 48 | 49 | ;; TODO: Display easy-to-read backtrace 50 | 51 | ;;; Code: 52 | 53 | (require 'promise-core) 54 | 55 | (defun promise--warn (message &rest args) 56 | (display-warning 'promise (apply #'format-message message args))) 57 | 58 | (defvar promise--default-whitelist '(void-function 59 | void-variable 60 | wrong-type-argument 61 | args-out-of-range)) 62 | 63 | (defvar promise--enabled nil) 64 | 65 | (defun promise-rejection-tracking-disable () 66 | (setf promise--enabled nil 67 | promise--on-handle nil 68 | promise--on-reject nil)) 69 | 70 | (defun promise-rejection-tracking-enable (&optional options) 71 | (when promise--enabled (promise-rejection-tracking-disable)) 72 | (setf promise--enabled t) 73 | (let ((id -1) 74 | (display-id -1) 75 | (rejections (make-hash-table))) 76 | (cl-flet* 77 | ((rejections (id symbol) (alist-get symbol (gethash id rejections))) 78 | (rejections-set (id symbol value) 79 | (setf (alist-get symbol (gethash id rejections)) 80 | value)) 81 | (options (sym) (alist-get sym options)) 82 | 83 | (on-unhandled (id) 84 | (when (or (options 'all-rejections) 85 | (promise--match-whitelist 86 | (rejections id 'error) 87 | (or (options 'whitelist) 88 | promise--default-whitelist))) 89 | (rejections-set id 'display-id (cl-incf display-id)) 90 | (cond 91 | ((options 'on-unhandled) 92 | (rejections-set id 'logged t) 93 | (funcall (options 'on-unhandled) 94 | (rejections id 'display-id) 95 | (rejections id 'error))) 96 | (t 97 | (rejections-set id 'logged t) 98 | (promise--log-error (rejections id 'display-id) 99 | (rejections id 'error)))))) 100 | (on-handled (id) 101 | (when (rejections id 'logged) 102 | (cond 103 | ((options 'on-handled) 104 | (funcall (options 'on-handled) 105 | (rejections id 'display-id) 106 | (rejections id 'error))) 107 | ((not (rejections id 'on-unhandled)) 108 | (promise--warn "Promise Rejection Handled (id:%d):" 109 | (rejections id 'display-id)) 110 | (promise--warn " This means you can ignore any previous messages of the form \"Possible Unhandled Promise Rejection\" with id %d." 111 | (rejections id 'display-id))))))) 112 | (setf promise--on-handle 113 | (lambda (promise) 114 | (when (and (= (promise-_state promise) 2) ; IS REJECTED 115 | (gethash (promise-_rejection-id promise) rejections)) 116 | (if (rejections (promise-_rejection-id promise) 'logged) 117 | (on-handled (promise-_rejection-id promise)) 118 | (cancel-timer (rejections (promise-_rejection-id promise) 'timeout))) 119 | (remhash (promise-_rejection-id promise) rejections))) 120 | promise--on-reject 121 | (lambda (promise err) 122 | (when (zerop (promise-_deferred-state promise)) ; not yet handled 123 | (setf (promise-_rejection-id promise) (cl-incf id)) 124 | (puthash (promise-_rejection-id promise) 125 | `((display-id . nil) 126 | (error . ,err) 127 | (timeout . ,(run-at-time 128 | (if (promise--match-whitelist 129 | err promise--default-whitelist) 130 | 0.1 131 | 2) 132 | nil 133 | (lambda () 134 | (on-unhandled (promise-_rejection-id promise))))) 135 | (logged . nil)) 136 | rejections))))))) 137 | 138 | (defun promise--log-error (id error) 139 | (promise--warn "Possible Unhandled Promise Rejection (id:%d):" id) 140 | (display-warning 'promise (prin1-to-string error))) 141 | 142 | (defun promise--match-whitelist (error list) 143 | (cl-some (lambda (cls) 144 | (eq (or (and (consp error) 145 | (car error)) 146 | error) 147 | cls)) 148 | list)) 149 | 150 | (provide 'promise-rejection-tracking) 151 | ;;; promise-rejection-tracking.el ends here 152 | -------------------------------------------------------------------------------- /promise.el: -------------------------------------------------------------------------------- 1 | ;;; promise.el --- Promises/A+ -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2016-2017 chuntaro 4 | 5 | ;; Author: chuntaro 6 | ;; URL: https://github.com/chuntaro/emacs-promise 7 | ;; Package-Requires: ((emacs "25.1")) 8 | ;; Version: 1.1 9 | ;; Keywords: async promise convenience 10 | 11 | ;; This program is free software; you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation, either version 3 of the License, or 14 | ;; (at your option) any later version. 15 | 16 | ;; This program is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with this program. If not, see . 23 | 24 | ;; The original JavaScript code is: 25 | ;; 26 | ;; Copyright (c) 2014 Forbes Lindesay 27 | ;; 28 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 29 | ;; of this software and associated documentation files (the "Software"), to deal 30 | ;; in the Software without restriction, including without limitation the rights 31 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 32 | ;; copies of the Software, and to permit persons to whom the Software is 33 | ;; furnished to do so, subject to the following conditions: 34 | ;; 35 | ;; The above copyright notice and this permission notice shall be included in 36 | ;; all copies or substantial portions of the Software. 37 | ;; 38 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 39 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 40 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 41 | ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 42 | ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 43 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 44 | ;; THE SOFTWARE. 45 | 46 | ;;; Commentary: 47 | 48 | ;; This is a simple implementation of Promises/A+. 49 | ;; 50 | ;; This implementation ported the following Promises/A+ implementation faithfully. 51 | ;; https://github.com/then/promise 52 | ;; 53 | ;; * The same API as JavaScript version Promise can be used. 54 | ;; * then, catch, resolve, reject, all, race, etc... 55 | ;; * supports "thenable" 56 | ;; * supports "Inheritance of Promise" 57 | ;; * supports "rejection-tracking" 58 | ;; 59 | ;; Usage: 60 | ;; See `promise-examples.el' for details. 61 | ;; https://raw.githubusercontent.com/chuntaro/emacs-promise/master/examples/promise-examples.el 62 | ;; You can check the operation while downloading and running it interactively. 63 | ;; 64 | ;; (require 'promise) 65 | ;; 66 | ;; ;; Please be sure to enable it when developing. 67 | ;; (promise-rejection-tracking-enable '((all-rejections . t))) 68 | ;; 69 | ;; (defun do-something-async (delay-sec value) 70 | ;; "Return `Promise' to resolve the value asynchronously." 71 | ;; (promise-new (lambda (resolve _reject) 72 | ;; (run-at-time delay-sec 73 | ;; nil 74 | ;; (lambda () 75 | ;; (funcall resolve value)))))) 76 | ;; 77 | ;; (defun example4 () 78 | ;; "All processes are asynchronous Promise chain." 79 | ;; (promise-chain (do-something-async 1 33) 80 | ;; (then (lambda (result) 81 | ;; (message "first result: %s" result) 82 | ;; (do-something-async 1 (* result 2)))) 83 | ;; 84 | ;; (then (lambda (second-result) 85 | ;; (message "second result: %s" second-result) 86 | ;; (do-something-async 1 (* second-result 2)))) 87 | ;; 88 | ;; (then (lambda (third-result) 89 | ;; (message "third result: %s" third-result))))) 90 | 91 | ;;; Code: 92 | 93 | (require 'promise-es6-extensions) 94 | (require 'promise-done) 95 | (require 'promise-finally) 96 | (require 'promise-rejection-tracking) 97 | 98 | ;;;###autoload 99 | (defmacro promise-chain (promise &rest body) 100 | "Extract PROMISE, BODY include then, catch, done and finally. 101 | 102 | Extract the following code... 103 | 104 | (promise-chain (promise-new ...) 105 | (then 106 | (lambda (value) 107 | ...)) 108 | 109 | (catch 110 | (lambda (reason) 111 | ...)) 112 | 113 | (done 114 | (lambda (value) 115 | ...)) 116 | 117 | (finally 118 | (lambda () ...)) 119 | 120 | ;; Anaphoric versions of `then' and `catch'. 121 | 122 | (thena (message \"result -> %s\" result) 123 | ...) 124 | 125 | (catcha (message \"error: reason -> %s\" reason) 126 | ...)) 127 | 128 | as below. 129 | 130 | (let ((promise (promise-new ...))) 131 | (setf promise (promise-then promise 132 | (lambda (value) 133 | ...))) 134 | 135 | (setf promise (promise-catch promise 136 | (lambda (value) 137 | ...))) 138 | 139 | (setf promise (promise-done promise 140 | (lambda (reason) 141 | ...))) 142 | 143 | (setf promise (promise-finally promise 144 | (lambda () 145 | ...))) 146 | 147 | (setf promise (promise-then promise 148 | (lambda (result) 149 | (message \"result -> %s\" result) 150 | ...))) 151 | 152 | (setf promise (promise-catch promise 153 | (lambda (reason) 154 | (message \"error: reason -> %s\" reason) 155 | ...))) 156 | promise)" 157 | (declare (indent 1) (debug t)) 158 | `(let ((promise ,promise)) 159 | ,@(mapcar (lambda (sexp) 160 | (let ((fn (car-safe sexp)) 161 | (args (cdr-safe sexp))) 162 | (cl-case fn 163 | (promise-new 164 | `(setf promise ,sexp)) 165 | ((promise-then 166 | promise-catch 167 | promise-done 168 | promise-finally) 169 | `(setf promise (,fn promise ,@args))) 170 | (catch 171 | `(setf promise (promise-catch promise ,@args))) 172 | (then 173 | `(setf promise (promise-then promise ,@args))) 174 | (done 175 | `(setf promise (promise-done promise ,@args))) 176 | (finally 177 | `(setf promise (promise-finally promise ,@args))) 178 | (thena 179 | `(setf promise (promise-then promise (lambda (result) ,@args)))) 180 | (catcha 181 | `(setf promise (promise-catch promise (lambda (reason) ,@args)))) 182 | (otherwise 183 | sexp)))) 184 | body) 185 | promise)) 186 | 187 | ;; 188 | ;; Promise version of various utility functions 189 | ;; 190 | 191 | (require 'url-http) 192 | 193 | (defun promise:run-at-time (time function &rest args) 194 | "Return promise to funcall FUNCTION with ARGS at specified TIME. 195 | 196 | Arguments: 197 | - TIME can accept the various formats. See `run-at-time'. 198 | - FUNCTION is funcalled with ARGS. 199 | 200 | Resolve: 201 | - The return value from funcalled FUNCTION. 202 | 203 | Reject: 204 | - " 205 | (declare (indent 1)) 206 | (promise-new 207 | (lambda (resolve _reject) 208 | (run-at-time time nil 209 | (lambda () 210 | (funcall resolve (apply function args))))))) 211 | 212 | (defun promise:delay (time &optional value) 213 | "Return promise to delay specified TIME. 214 | 215 | Arguments: 216 | - TIME can accept the various formats. See `run-at-time'. 217 | - VALUE is return value when resolved this function. 218 | 219 | Resolve: 220 | - VALUE 221 | 222 | Reject: 223 | - " 224 | (declare (indent 1)) 225 | (promise-new 226 | (lambda (resolve _reject) 227 | (run-at-time time 228 | nil 229 | (lambda () 230 | (funcall resolve value)))))) 231 | 232 | (defun promise:time-out (time &optional reason) 233 | "Return promise to reject after specified TIME with REASON. 234 | 235 | Arguments: 236 | - TIME an accept various format. See `run-at-time'. 237 | - REASON is return value when rejected this function. 238 | 239 | Resolve: 240 | - 241 | 242 | Reject: 243 | - REASON" 244 | (declare (indent 1)) 245 | (promise-new 246 | (lambda (_resolve reject) 247 | (run-at-time time nil 248 | (lambda () 249 | (funcall reject reason)))))) 250 | 251 | (defun promise:make-process (command) 252 | "Return promise to make new asynchronous COMMAND. 253 | 254 | Arguments: 255 | - COMMAND is program and shell arguments list of string. 256 | 257 | See `promise:make-process-with-handler' for Resolve and Reject sections." 258 | (funcall #'promise:make-process-with-handler command)) 259 | 260 | (defun promise:make-process-send-buffer (command buf) 261 | "Return promise to make new asynchronous COMMAND. 262 | 263 | Arguments: 264 | - COMMAND is program and shell arguments list of string. 265 | - BUF is buffer, a format that can be accepted by `with-current-buffer'. 266 | `buffer-string' of BUF is sent with EOF after process has been invoked. 267 | 268 | See `promise:make-process-with-handler' for Resolve and Reject sections." 269 | (funcall #'promise:make-process-with-handler 270 | command 271 | (lambda (proc) 272 | (with-current-buffer buf 273 | (process-send-region proc (point-min) (point-max)) 274 | (process-send-eof proc))))) 275 | 276 | (defun promise:make-process-send-string (command string) 277 | "Return promise to make new asynchronous COMMAND. 278 | 279 | Arguments: 280 | - COMMAND is program and shell arguments list of string. 281 | - STRING is sent with EOF after process has been invoked. 282 | 283 | See `promise:make-process-with-handler' for Resolve and Reject sections." 284 | (funcall #'promise:make-process-with-handler 285 | command 286 | (lambda (proc) 287 | (process-send-string proc string) 288 | (process-send-eof proc)))) 289 | 290 | (defun promise:make-process-with-handler (command &optional handler merge-stderr) 291 | "Return promise to make new asynchronous COMMAND. 292 | 293 | Arguments: 294 | - COMMAND is program and shell arguments list of string. 295 | - HANDLER is function, called with process object after program is invoked. 296 | - MERGE-STDERR is boolean, whether merge stdout and stderr or not. 297 | 298 | Resolve: 299 | - A list like as (stdout stderr) when process finish with exitcode 0. 300 | stdout and stderr are string. 301 | 302 | Reject: 303 | - A list like as (event stdout stderr) when process doesn't finish exitcode 0. 304 | event, stdout and stderr are string. 305 | The event is documented at https://www.gnu.org/software/emacs/manual/html_node/elisp/Sentinels.html" 306 | (promise-new 307 | (lambda (resolve reject) 308 | (let* ((program (car command)) 309 | (stdout (generate-new-buffer (concat "*" program "-stdout*"))) 310 | (stderr (unless merge-stderr 311 | (generate-new-buffer (concat "*" program "-stderr*")))) 312 | (stderr-pipe (unless merge-stderr 313 | (make-pipe-process 314 | :name (concat "*" program "-stderr-pipe*") 315 | :noquery t 316 | ;; use :filter instead of :buffer, to get rid of "Process Finished" lines 317 | :filter (lambda (_ output) 318 | (with-current-buffer stderr 319 | (insert output)))))) 320 | (cleanup (lambda () 321 | (kill-buffer stdout) 322 | (unless merge-stderr 323 | (delete-process stderr-pipe) 324 | (kill-buffer stderr))))) 325 | (condition-case err 326 | (let ((proc (if merge-stderr 327 | (make-process :name program :buffer stdout :command command) 328 | (make-process :name program :buffer stdout :command command :stderr stderr-pipe)))) 329 | (set-process-sentinel 330 | proc 331 | (lambda (_process event) 332 | (unwind-protect 333 | (let ((stdout-str (with-current-buffer stdout 334 | (buffer-string))) 335 | (stderr-str (unless merge-stderr 336 | (with-current-buffer stderr 337 | (buffer-string))))) 338 | (if (string= event "finished\n") 339 | (funcall resolve (list stdout-str stderr-str)) 340 | (funcall reject (list event stdout-str stderr-str)))) 341 | (funcall cleanup)))) 342 | (when handler 343 | (funcall handler proc))) 344 | (error (funcall cleanup) 345 | (signal (car err) (cdr err)))))))) 346 | 347 | (require 'subr-x) 348 | (defun promise:maybe-message (msg) 349 | "Display MSG if non-blank." 350 | (let ((m (string-trim-right msg))) 351 | (when (not (string-empty-p m)) 352 | (message "%s" m)))) 353 | 354 | (require 'seq) 355 | (defun promise:make-process-string (command) 356 | "Return promise to make new asynchronous COMMAND. 357 | 358 | Arguments: 359 | - COMMAND is program and shell arguments list of string. 360 | 361 | Resolve: 362 | - Process stdout as string when process finish with exitcode 0. 363 | 364 | Reject: 365 | - Event as string represented process exit state. 366 | The event is documented at https://www.gnu.org/software/emacs/manual/html_node/elisp/Sentinels.html" 367 | (promise-then 368 | (funcall #'promise:make-process command) 369 | (lambda (res) 370 | (seq-let (stdout stderr) res 371 | (promise:maybe-message (propertize stderr 'face '(:foreground "yellow"))) 372 | stdout)) 373 | (lambda (err) 374 | (seq-let (event stdout stderr) err 375 | (promise:maybe-message (propertize stdout 'face '(:foreground "black" :background "white"))) 376 | (promise:maybe-message (propertize stderr 'face '(:foreground "red"))) 377 | (promise-reject event))))) 378 | 379 | (defun promise:make-shell-command (script &optional dir) 380 | "Return promise to make new asynchronous shell SCRIPT. 381 | 382 | Arguments: 383 | - SCRIPT is string, will be passed sh -c. 384 | - DIR is directory path in which SCRIPT will be executed. 385 | 386 | See `promise:make-process-string' for Resolve and Reject sections." 387 | (let ((default-directory (or dir default-directory))) 388 | (promise:make-process-string (list shell-file-name shell-command-switch script)))) 389 | 390 | (defun promise:make-thread (function &rest args) 391 | "Return promise to make new thread via `make-thread'. 392 | 393 | Arguments: 394 | - FUNCTION is funcalled with ARGS in new thread. 395 | 396 | Resolve: 397 | - Return value from funcalled FUNCTION in the thread. 398 | 399 | Reject: 400 | - Error object while running in the thread." 401 | (promise-new 402 | (lambda (resolve reject) 403 | (if (not (fboundp 'make-thread)) 404 | (error "`promise:make-thread' needs `make-thread' attached to Emacs-26.1 or above") 405 | (make-thread 406 | (lambda () 407 | (condition-case err 408 | (funcall resolve (apply function args)) 409 | (error (funcall reject err))))))))) 410 | 411 | (defun promise:wrap-message (promise) 412 | "Return promise to show debug message after PROMISE resolved. 413 | 414 | Arguments: 415 | - PROMISE is any promise object. 416 | 417 | Resolve: 418 | - Return original return value when PROMISE resolved. 419 | 420 | Reject: 421 | - Return original return value when PROMISE rejected." 422 | (promise-new 423 | (lambda (resolve reject) 424 | (promise-then 425 | promise 426 | (lambda (res) 427 | (message "%s: %s" 428 | (propertize "Result" 'face '(:foreground "green")) 429 | (string-trim-right res)) 430 | (funcall resolve res)) 431 | (lambda (err) 432 | (message "%s: %s" 433 | (propertize "Error" 'face '(:foreground "red")) 434 | (string-trim-right err)) 435 | (funcall reject err)))))) 436 | 437 | (defun promise:url-retrieve (url) 438 | "Return promise to retrieve response body from URL. 439 | 440 | Arguments: 441 | - URL is either a string or a parsed URL. See `url-retrieve'. 442 | 443 | Resolve: 444 | - Response body as a string retrieved from the URL. 445 | 446 | Reject: 447 | - Error object while retrieving URL." 448 | (promise-new 449 | (lambda (resolve reject) 450 | (url-retrieve url 451 | (lambda (status) 452 | ;; All errors are reliably captured and rejected with appropriate values. 453 | (if (plist-get status :error) 454 | (funcall reject (plist-get status :error)) 455 | (condition-case err 456 | (if (not (url-http-parse-headers)) 457 | (funcall reject (buffer-string)) 458 | (search-forward-regexp "\n\\s-*\n" nil t) 459 | (funcall resolve (buffer-substring (point) (point-max)))) 460 | (error (funcall reject err))))))))) 461 | 462 | (require 'xml) ; for `xml-parse-region' 463 | 464 | (defun promise:xml-retrieve (url) 465 | "Return promise to retrieve XML object parsed from contents from URL. 466 | 467 | Arguments: 468 | - URL is either a string or a parsed URL. See `url-retrieve'. 469 | 470 | Resolve: 471 | - XML object parsed by `xml-parse-region'. 472 | 473 | Reject: 474 | - Error object while retrieving URL and parsing contents." 475 | (promise-new 476 | (lambda (resolve reject) 477 | (url-retrieve url 478 | (lambda (status) 479 | ;; All errors are reliably captured and rejected with appropriate values. 480 | (if (plist-get status :error) 481 | (funcall reject (plist-get status :error)) 482 | (condition-case err 483 | (if (not (url-http-parse-headers)) 484 | (funcall reject (buffer-string)) 485 | (search-forward-regexp "\n\\s-*\n" nil t) 486 | (funcall resolve (xml-parse-region))) 487 | (error (funcall reject err))))))))) 488 | 489 | (defun promise:request (url) 490 | "Return promise to request URL via `request'. 491 | 492 | Arguments: 493 | - URL is a target url as string. 494 | 495 | Resolve: 496 | - Response body as string. 497 | 498 | Reject: 499 | - A string list like as (status-code response-header response-body)" 500 | (promise:request-with-args url nil)) 501 | 502 | (defun promise:request-post (url data) 503 | "Return promise to POST DATA to URL via `request'. 504 | 505 | Arguments: 506 | - URL is a target url as string. 507 | - DATA is post data alist. 508 | 509 | Resolve: 510 | - Response body as string. 511 | 512 | Reject: 513 | - A string list like as (status-code response-header response-body)" 514 | (declare (indent 1)) 515 | (promise:request-with-args url `(:type "POST" :data ',data))) 516 | 517 | (declare-function request "request.el" (url &rest settings)) 518 | (declare-function request-response-status-code "request.el" (response)) 519 | (declare-function request-response--raw-header "request.el" (response)) 520 | (declare-function request-response-data "request.el" (response)) 521 | 522 | (defun promise:request-with-args (url arglist) 523 | "Return promise to request URL via `request' with ARGLIST. 524 | 525 | Arguments: 526 | - URL is a target url as string. 527 | 528 | Resolve: 529 | - Response body as string. 530 | 531 | Reject: 532 | - A string list like as (status-code response-header response-body)" 533 | (declare (indent 1)) 534 | 535 | (require 'request) 536 | (promise-new 537 | (lambda (resolve reject) 538 | (when (plist-get arglist :success) 539 | (funcall reject "Success callback function is not customizable")) 540 | (when (plist-get arglist :error) 541 | (funcall reject "Error callback function is not customizable")) 542 | (apply #'request url 543 | :success (cl-function 544 | (lambda (&key data &allow-other-keys) 545 | (funcall resolve data))) 546 | :error (cl-function 547 | (lambda (&key response &allow-other-keys) 548 | (funcall reject 549 | (list (request-response-status-code response) 550 | (request-response--raw-header response) 551 | (request-response-data response))))) 552 | arglist)))) 553 | 554 | (declare-function async-start "async.el" (start-func &optional finish-func)) 555 | (declare-function async-when-done "async.el" (proc &optional _change)) 556 | 557 | (defun promise:async-start (start-func &optional finish-func) 558 | "Return promise to eval function in a new Emacs process via `async-start'. 559 | 560 | Arguments: 561 | - START-FUNC is function that will be evaled in new Emacs. 562 | - FINISH-FUNC is function that will be evaled after START-FUNC evaled. 563 | 564 | Resolve: 565 | - Return value from START-FUNC in the Emacs. 566 | 567 | Reject: 568 | - Error object while evaluating START-FUNC and FINISH-FUNC." 569 | (require 'async) 570 | (promise-new 571 | (lambda (resolve reject) 572 | (set-process-sentinel (async-start start-func 573 | (lambda (result) 574 | (when finish-func 575 | (funcall finish-func result)) 576 | (funcall resolve result))) 577 | (lambda (process event) 578 | (condition-case reason 579 | (async-when-done process event) 580 | (error (funcall reject reason)))))))) 581 | 582 | (defun promise-wait (timeout promise) 583 | "Return promise to wait synchronously until PROMISE is resolved or rejected or TIMEOUT. 584 | 585 | Arguments: 586 | - TIMEOUT can accept the various formats. See `run-at-time'. 587 | - PROMISE is any promise object. 588 | 589 | Resolve: 590 | - Return (:fullfilled value), value is PROMISE resolved value. 591 | 592 | Reject: 593 | - Return (:rejected reason), reason is PROMISE rejected reason. 594 | 595 | Timeout: 596 | - Return (:timeouted)." 597 | (declare (indent 1)) 598 | (catch 'done 599 | (let* (handled 600 | (timer (run-at-time timeout nil 601 | (lambda () 602 | (unless handled 603 | (setq handled t) 604 | (throw 'done (promise-reject '(:timeouted)))))))) 605 | (promise-then promise 606 | (lambda (value) 607 | (unless handled 608 | (setq handled t) 609 | (cancel-timer timer) 610 | (throw 'done (promise-resolve `(:fullfilled ,value))))) 611 | (lambda (reason) 612 | (unless handled 613 | (setq handled t) 614 | (cancel-timer timer) 615 | (throw 'done (promise-reject `(:rejected ,reason)))))) 616 | (while t (accept-process-output))))) 617 | 618 | (defun promise-wait-value (promise) 619 | "Return orignal value form PROMISE return value of `promise-wait'." 620 | (seq-let (state value) (promise-_value promise) 621 | (cond 622 | ((eq :fullfilled state) value) 623 | ((eq :rejected state) (error "Rejected: %s" (prin1-to-string value))) 624 | ((eq :timeouted state) (error "Timeouted: %s" (prin1-to-string value)))))) 625 | 626 | (defun promise-concurrent--internal (concurrent limit promisefn &optional no-reject-immediately-p) 627 | "Internal function of `promise-concurrent'. 628 | 629 | Arguments: 630 | - CONCURRENT is limited number of concurrent promises. 631 | - LIMIT is number of PROMISEFN executions. 632 | - PROMISEFN is function should return any promise object. 633 | - If NO-REJECT-IMMEDIATELY-P is non-nil, returned promise is not reject immidiately." 634 | (declare (indent 2)) 635 | (let ((pipeline (make-vector concurrent nil)) 636 | (results (make-vector limit nil)) 637 | (count -1) 638 | reasons) 639 | (dotimes (i concurrent) 640 | (aset pipeline i 641 | (promise-new 642 | (lambda (resolve reject) 643 | (cl-labels 644 | ((worker (inx) 645 | (if (not (< inx limit)) 646 | (funcall resolve) 647 | (promise-chain (funcall promisefn inx) 648 | (then (lambda (res) 649 | (aset results inx res) 650 | (worker (cl-incf count)))) 651 | (catch (lambda (reason) 652 | (if (not no-reject-immediately-p) 653 | (funcall reject reason) 654 | (push `(,inx ,reason) reasons) 655 | (worker (cl-incf count))))))))) 656 | (worker (cl-incf count))))))) 657 | (promise-chain (promise-all pipeline) 658 | (then (lambda (_) 659 | (if (not reasons) 660 | results 661 | (promise-reject `(,results ,reasons)))))))) 662 | 663 | (defun promise-concurrent (concurrent limit promisefn) 664 | "Return promise to run a limited number of concurrent promises. 665 | 666 | This function returns promise which immediately rejected if one 667 | of promises fails. This behavior corresponds to `promise-all'. 668 | See `promise-concurrent-no-reject-immidiately' with no reject immidiately. 669 | 670 | Arguments: 671 | - CONCURRENT is limited number of concurrent promises. 672 | - LIMIT is number of PROMISEFN executions. 673 | - PROMISEFN is function should return any promise object. 674 | 675 | Resolve: 676 | - Return vector includes values resolved for promise with respect to order. 677 | 678 | Reject: 679 | - Return reason for the first rejection." 680 | (declare (indent 2)) 681 | (funcall #'promise-concurrent--internal concurrent limit promisefn)) 682 | 683 | (defun promise-concurrent-no-reject-immidiately (concurrent limit promisefn) 684 | "Return promise to run a limited number of concurrent promises. 685 | 686 | This function returns promise which execute the whole promises if 687 | a promise fails. If all promises are fulfilled, only vectors 688 | with resolved values are returned. If one of promise is 689 | rejected, the whole promises are executed and the index and 690 | reason rejected as the second return value is returned after the 691 | whole state has been determined. In this case, the index location 692 | of the first return value is nil. 693 | See `promise-concurrent' with reject immidiately. 694 | 695 | Arguments: 696 | - CONCURRENT is limited number of concurrent promises. 697 | - LIMIT is number of PROMISEFN executions. 698 | - PROMISEFN is function should return any promise object. 699 | 700 | Resolve: 701 | - Return vector includes values resolved for promise with respect to order. 702 | 703 | Reject: 704 | - Return ( ) 705 | includes values resolved for promise with respect to order. 706 | is list of (index reason)." 707 | (declare (indent 2)) 708 | (funcall #'promise-concurrent--internal concurrent limit promisefn :no-reject-immediately)) 709 | 710 | (provide 'promise) 711 | ;;; promise.el ends here 712 | -------------------------------------------------------------------------------- /test/emacs-promise-test.el: -------------------------------------------------------------------------------- 1 | ;;; -*- lexical-binding: t -*- 2 | 3 | (ert-deftest-async 4 | test/promise/errors-in-resolver-are-rejections (done) 5 | (promise-done 6 | (promise-chain 7 | (promise-new (lambda (resolve reject) 8 | (error "wut"))) 9 | (then (lambda (result) 10 | (funcall done "Error did not cause promise rejection"))) 11 | (promise-catch (lambda (exception) 12 | (should (equal (error-message-string exception) "wut")) 13 | (funcall done))) 14 | (promise-catch 'done)))) 15 | 16 | (ert-deftest-async 17 | test/promise/errors-in-then-are-rejections (done) 18 | (promise-done 19 | (promise-chain 20 | (promise-new (lambda (resolve reject) 21 | (funcall resolve "yeah"))) 22 | (then (lambda (result) 23 | (error "wut"))) 24 | (then (lambda (result) 25 | (funcall done "Error did not cause promise rejection"))) 26 | (promise-catch (lambda (exception) 27 | (should (equal (error-message-string exception) "wut")) 28 | (funcall done))) 29 | (promise-catch 'done)))) 30 | 31 | (ert-deftest-async 32 | test/promise/resolver-called-synchronously (done) 33 | (let ((chain-constructor-has-finished nil) 34 | (resolver-was-called nil)) 35 | (promise-done 36 | (promise-chain 37 | (promise-new (lambda (resolve reject) 38 | (should (equal chain-constructor-has-finished nil)) 39 | (setq resolver-was-called t) 40 | (funcall resolve 'foo))) 41 | (then (lambda (result) 42 | (should (equal result 'foo)) 43 | (funcall done))) 44 | (promise-catch (lambda (exception) 45 | (funcall done exception)))) 46 | (setq chain-constructor-has-finished t) 47 | (should (equal resolver-was-called t))))) 48 | -------------------------------------------------------------------------------- /test/test-helper.el: -------------------------------------------------------------------------------- 1 | ;;; -*- lexical-binding: t -*- 2 | 3 | (require 'f) 4 | (require 'ert-async) 5 | 6 | (defvar root-test-path 7 | (f-dirname (f-this-file))) 8 | 9 | (defvar root-code-path 10 | (f-parent root-test-path)) 11 | 12 | (add-to-list 'load-path root-code-path) 13 | 14 | (require 'promise) 15 | --------------------------------------------------------------------------------