sekka 1.5.3 → 1.5.4

data/emacs/deferred.el

@@ -0,0 +1,956 @@
+;;; deferred.el --- Simple asynchronous functions for emacs lisp
+
+;; Copyright (C) 2010, 2011, 2012  SAKURAI Masashi
+
+;; Author: SAKURAI Masashi <m.sakurai at kiwanami.net>
+;; Version: 0.3.2
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; 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)
+
+(defvar deferred:version nil "deferred.el version")
+(setq deferred:version "0.3.2")
+
+;;; 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
+             with it = nil
+             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 for i in args collect (gensym))))
+  `(lambda (,@argsyms)
+     (lexical-let (self)
+       (setq self (lambda( ,@args ) ,@body))
+       (funcall self ,@argsyms)))))
+
+(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 err2 
+         (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."
+  (progn 
+    (lexical-let ((last-value 'deferred:undefined*))
+      (deferred:nextc d
+        (lambda (x) (setq last-value x)))
+      (while (eq 'deferred:undefined* last-value)
+        (sit-for 0.05)
+        (sleep-for 0.05))
+      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-list)
+  "[internal] Return non-nil if TIMES-OR-LIST is the number zero or nil."
+  (or (and (numberp times-or-list) (<= times-or-list 0))
+      (and (listp times-or-list) (null times-or-list))))
+
+(defun deferred:loop (times-or-list func)
+  "Return a iteration deferred object."
+  (deferred:message "LOOP : %s" times-or-list)
+  (if (deferred:empty-p times-or-list) (deferred:next)
+    (lexical-let*
+        (items (rd 
+                (cond
+                 ((numberp times-or-list)
+                  (loop for i from 0 below times-or-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))
+                 ((listp times-or-list)
+                  (loop for i in times-or-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<KEY . VALUE>" )
+  (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<LIST>" )
+  (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<KEY . VALUE>" )
+  (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<LIST>" )
+  (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))
+
+(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)))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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)
+         (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))
+                (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
+  '(progn
+
+     (defun deferred:url-retrieve (url &optional cbargs)
+       "A wrapper function for url-retrieve. The next deferred
+object receives the buffer object that URL will load
+into. Currently dynamic binding variables are not supported."
+       (lexical-let ((nd (deferred:new)) (url url) (cbargs cbargs) buf)
+         (deferred:next
+           (lambda (x)
+             (condition-case err
+                 (setq buf
+                       (url-retrieve 
+                        url (lambda (xx) (deferred:post-task nd 'ok buf))
+                        cbargs))
+                 (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)
+       "Perform a HTTP GET method with `url-retrieve'. PARAMS is
+a parameter list of (key . value) or key. 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:$
+                  (deferred:url-retrieve url)
+                  (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)
+       "Perform a HTTP POST method with `url-retrieve'. PARAMS is
+a parameter list of (key . value) or key. The next deferred
+object receives the buffer object that URL will load into."
+       (lexical-let ((nd (deferred:new)) 
+                     (url url) (params params)
+                     buf)
+         (deferred:next
+           (lambda (x)
+             (let ((url-request-method "POST")
+                   (url-request-extra-headers
+                    '(("Content-Type" . "application/x-www-form-urlencoded")))
+                   (url-request-data
+                    (deferred:url-param-serialize params)))
+               (condition-case err
+                   (setq buf 
+                         (url-retrieve 
+                          url 
+                          (lambda (&rest args) 
+                            (deferred:post-task nd 'ok buf))))
+                 (error (deferred:post-task nd 'ng err))))
+             nil))
+         (setf (deferred-cancel nd)
+               (lambda (x) 
+                 (when (buffer-live-p buf)
+                   (kill-buffer buf))))
+         (let ((d (deferred:nextc nd '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