klimi
/
dotfiles


								;;; async.el --- Asynchronous processing in Emacs -*- lexical-binding: t -*-


								;; Copyright (C) 2012-2016 Free Software Foundation, Inc.


								;; Author: John Wiegley <jwiegley@gmail.com>

								;; Created: 18 Jun 2012

								;; Version: 1.9.3


								;; Keywords: async

								;; X-URL: https://github.com/jwiegley/emacs-async


								;; 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 2, 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 GNU Emacs; see the file COPYING.  If not, write to the

								;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,

								;; Boston, MA 02111-1307, USA.


								;;; Commentary:


								;; Adds the ability to call asynchronous functions and process with ease.  See

								;; the documentation for `async-start' and `async-start-process'.


								;;; Code:


								(eval-when-compile (require 'cl-lib))


								(defgroup async nil

								  "Simple asynchronous processing in Emacs"

								  :group 'emacs)


								(defcustom async-variables-noprops-function #'async--purecopy

								  "Default function to remove text properties in variables."

								  :group 'async

								  :type 'function)


								(defvar async-debug nil)

								(defvar async-send-over-pipe t)

								(defvar async-in-child-emacs nil)

								(defvar async-callback nil)

								(defvar async-callback-for-process nil)

								(defvar async-callback-value nil)

								(defvar async-callback-value-set nil)

								(defvar async-current-process nil)

								(defvar async--procvar nil)


								(defun async--purecopy (object)

								  "Remove text properties in OBJECT.


								Argument OBJECT may be a list or a string, if anything else it

								is returned unmodified."

								  (cond ((stringp object)

								         (substring-no-properties object))

								        ((consp object)

								         (cl-loop for elm in object

								                  ;; A string.

								                  if (stringp elm)

								                  collect (substring-no-properties elm)

								                  else

								                  ;; Proper lists.

								                  if (and (consp elm) (null (cdr (last elm))))

								                  collect (async--purecopy elm)

								                  else

								                  ;; Dotted lists.

								                  ;; We handle here only dotted list where car and cdr

								                  ;; are atoms i.e. (x . y) and not (x . (x . y)) or

								                  ;; (x . (x y)) which should fit most cases.

								                  if (and (consp elm) (cdr (last elm)))

								                  collect (let ((key (car elm))

								                                (val (cdr elm)))

								                            (cons (if (stringp key)

								                                      (substring-no-properties key)

								                                    key)

								                                  (if (stringp val)

								                                      (substring-no-properties val)

								                                    val)))

								                  else

								                  collect elm))

								        (t object)))


								(defun async-inject-variables

								  (include-regexp &optional predicate exclude-regexp noprops)

								  "Return a `setq' form that replicates part of the calling environment.


								It sets the value for every variable matching INCLUDE-REGEXP and

								also PREDICATE.  It will not perform injection for any variable

								matching EXCLUDE-REGEXP (if present) or representing a syntax-table

								i.e. ending by \"-syntax-table\".

								When NOPROPS is non nil it tries to strip out text properties of each

								variable's value with `async-variables-noprops-function'.


								It is intended to be used as follows:


								    (async-start

								       `(lambda ()

								          (require 'smtpmail)

								          (with-temp-buffer

								            (insert ,(buffer-substring-no-properties (point-min) (point-max)))

								            ;; Pass in the variable environment for smtpmail

								            ,(async-inject-variables \"\\`\\(smtpmail\\|\\(user-\\)?mail\\)-\")

								            (smtpmail-send-it)))

								       'ignore)"

								  `(setq

								    ,@(let (bindings)

								        (mapatoms

								         (lambda (sym)

								           (let* ((sname (and (boundp sym) (symbol-name sym)))

								                  (value (and sname (symbol-value sym))))

								             (when (and sname

								                        (or (null include-regexp)

								                            (string-match include-regexp sname))

								                        (or (null exclude-regexp)

								                            (not (string-match exclude-regexp sname)))

								                        (not (string-match "-syntax-table\\'" sname)))

								               (unless (or (stringp value)

								                           (memq value '(nil t))

								                           (numberp value)

								                           (vectorp value))

								                 (setq value `(quote ,value)))

								               (when noprops

								                 (setq value (funcall async-variables-noprops-function

								                                      value)))

								               (when (or (null predicate)

								                         (funcall predicate sym))

								                 (setq bindings (cons value bindings)

								                       bindings (cons sym bindings)))))))

								        bindings)))


								(defalias 'async-inject-environment 'async-inject-variables)


								(defun async-handle-result (func result buf)

								  (if (null func)

								      (progn

								        (set (make-local-variable 'async-callback-value) result)

								        (set (make-local-variable 'async-callback-value-set) t))

								    (unwind-protect

								        (if (and (listp result)

								                 (eq 'async-signal (nth 0 result)))

								            (signal (car (nth 1 result))

								                    (cdr (nth 1 result)))

								          (funcall func result))

								      (unless async-debug

								        (kill-buffer buf)))))


								(defun async-when-done (proc &optional _change)

								  "Process sentinel used to retrieve the value from the child process."

								  (when (eq 'exit (process-status proc))

								    (with-current-buffer (process-buffer proc)

								      (let ((async-current-process proc))

								        (if (= 0 (process-exit-status proc))

								            (if async-callback-for-process

								                (if async-callback

								                    (prog1

								                        (funcall async-callback proc)

								                      (unless async-debug

								                        (kill-buffer (current-buffer))))

								                  (set (make-local-variable 'async-callback-value) proc)

								                  (set (make-local-variable 'async-callback-value-set) t))

								              (goto-char (point-max))

								              (backward-sexp)

								              (async-handle-result async-callback (read (current-buffer))

								                                   (current-buffer)))

								          (set (make-local-variable 'async-callback-value)

								               (list 'error

								                     (format "Async process '%s' failed with exit code %d"

								                             (process-name proc) (process-exit-status proc))))

								          (set (make-local-variable 'async-callback-value-set) t))))))


								(defun async--receive-sexp (&optional stream)

								  (let ((sexp (decode-coding-string (base64-decode-string

								                                     (read stream)) 'utf-8-auto))

									;; Parent expects UTF-8 encoded text.

									(coding-system-for-write 'utf-8-auto))

								    (if async-debug

								        (message "Received sexp {{{%s}}}" (pp-to-string sexp)))

								    (setq sexp (read sexp))

								    (if async-debug

								        (message "Read sexp {{{%s}}}" (pp-to-string sexp)))

								    (eval sexp)))


								(defun async--insert-sexp (sexp)

								  (let (print-level

									print-length

									(print-escape-nonascii t)

									(print-circle t))

								    (prin1 sexp (current-buffer))

								    ;; Just in case the string we're sending might contain EOF

								    (encode-coding-region (point-min) (point-max) 'utf-8-auto)

								    (base64-encode-region (point-min) (point-max) t)

								    (goto-char (point-min)) (insert ?\")

								    (goto-char (point-max)) (insert ?\" ?\n)))


								(defun async--transmit-sexp (process sexp)

								  (with-temp-buffer

								    (if async-debug

								        (message "Transmitting sexp {{{%s}}}" (pp-to-string sexp)))

								    (async--insert-sexp sexp)

								    (process-send-region process (point-min) (point-max))))


								(defun async-batch-invoke ()

								  "Called from the child Emacs process' command-line."

								  ;; Make sure 'message' and 'prin1' encode stuff in UTF-8, as parent

								  ;; process expects.

								  (let ((coding-system-for-write 'utf-8-auto))

								    (setq async-in-child-emacs t

									  debug-on-error async-debug)

								    (if debug-on-error

									(prin1 (funcall

										(async--receive-sexp (unless async-send-over-pipe

												       command-line-args-left))))

								      (condition-case err

									  (prin1 (funcall

										  (async--receive-sexp (unless async-send-over-pipe

													 command-line-args-left))))

									(error

									 (prin1 (list 'async-signal err)))))))


								(defun async-ready (future)

								  "Query a FUTURE to see if it is ready.


								I.e., if no blocking

								would result from a call to `async-get' on that FUTURE."

								  (and (memq (process-status future) '(exit signal))

								       (let ((buf (process-buffer future)))

								         (if (buffer-live-p buf)

								             (with-current-buffer buf

								               async-callback-value-set)

								             t))))


								(defun async-wait (future)

								  "Wait for FUTURE to become ready."

								  (while (not (async-ready future))

								    (sleep-for 0.05)))


								(defun async-get (future)

								  "Get the value from process FUTURE when it is ready.

								FUTURE is returned by `async-start' or `async-start-process' when

								its FINISH-FUNC is nil."

								  (and future (async-wait future))

								  (let ((buf (process-buffer future)))

								    (when (buffer-live-p buf)

								      (with-current-buffer buf

								        (async-handle-result

								         #'identity async-callback-value (current-buffer))))))


								(defun async-message-p (value)

								  "Return true of VALUE is an async.el message packet."

								  (and (listp value)

								       (plist-get value :async-message)))


								(defun async-send (&rest args)

								  "Send the given messages to the asychronous Emacs PROCESS."

								  (let ((args (append args '(:async-message t))))

								    (if async-in-child-emacs

								        (if async-callback

								            (funcall async-callback args))

								      (async--transmit-sexp (car args) (list 'quote (cdr args))))))


								(defun async-receive ()

								  "Send the given messages to the asychronous Emacs PROCESS."

								  (async--receive-sexp))


								;;;###autoload

								(defun async-start-process (name program finish-func &rest program-args)

								  "Start the executable PROGRAM asynchronously.  See `async-start'.

								PROGRAM is passed PROGRAM-ARGS, calling FINISH-FUNC with the

								process object when done.  If FINISH-FUNC is nil, the future

								object will return the process object when the program is

								finished.  Set DEFAULT-DIRECTORY to change PROGRAM's current

								working directory."

								  (let* ((buf (generate-new-buffer (concat "*" name "*")))

								         (proc (let ((process-connection-type nil))

								                 (apply #'start-process name buf program program-args))))

								    (with-current-buffer buf

								      (set (make-local-variable 'async-callback) finish-func)

								      (set-process-sentinel proc #'async-when-done)

								      (unless (string= name "emacs")

								        (set (make-local-variable 'async-callback-for-process) t))

								      proc)))


								(defvar async-quiet-switch "-Q"

								  "The Emacs parameter to use to call emacs without config.

								Can be one of \"-Q\" or \"-q\".

								Default is \"-Q\" but it is sometimes useful to use \"-q\" to have a

								enhanced config or some more variables loaded.")


								;;;###autoload

								(defun async-start (start-func &optional finish-func)

								  "Execute START-FUNC (often a lambda) in a subordinate Emacs process.

								When done, the return value is passed to FINISH-FUNC.  Example:


								    (async-start

								       ;; What to do in the child process

								       (lambda ()

								         (message \"This is a test\")

								         (sleep-for 3)

								         222)


								       ;; What to do when it finishes

								       (lambda (result)

								         (message \"Async process done, result should be 222: %s\"

								                  result)))


								If FINISH-FUNC is nil or missing, a future is returned that can

								be inspected using `async-get', blocking until the value is

								ready.  Example:


								    (let ((proc (async-start

								                   ;; What to do in the child process

								                   (lambda ()

								                     (message \"This is a test\")

								                     (sleep-for 3)

								                     222))))


								        (message \"I'm going to do some work here\") ;; ....


								        (message \"Waiting on async process, result should be 222: %s\"

								                 (async-get proc)))


								If you don't want to use a callback, and you don't care about any

								return value from the child process, pass the `ignore' symbol as

								the second argument (if you don't, and never call `async-get', it

								will leave *emacs* process buffers hanging around):


								    (async-start

								     (lambda ()

								       (delete-file \"a remote file on a slow link\" nil))

								     'ignore)


								Note: Even when FINISH-FUNC is present, a future is still

								returned except that it yields no value (since the value is

								passed to FINISH-FUNC).  Call `async-get' on such a future always

								returns nil.  It can still be useful, however, as an argument to

								`async-ready' or `async-wait'."

								  (let ((sexp start-func)

									;; Subordinate Emacs will send text encoded in UTF-8.

									(coding-system-for-read 'utf-8-auto))

								    (setq async--procvar

								          (async-start-process

								           "emacs" (file-truename

								                    (expand-file-name invocation-name

								                                      invocation-directory))

								           finish-func

								           async-quiet-switch "-l"

								           ;; Using `locate-library' ensure we use the right file

								           ;; when the .elc have been deleted.

								           (locate-library "async")

								           "-batch" "-f" "async-batch-invoke"

								           (if async-send-over-pipe

								               "<none>"

								               (with-temp-buffer

								                 (async--insert-sexp (list 'quote sexp))

								                 (buffer-string)))))

								    (if async-send-over-pipe

								        (async--transmit-sexp async--procvar (list 'quote sexp)))

								    async--procvar))


								(defmacro async-sandbox(func)

								  "Evaluate FUNC in a separate Emacs process, synchronously."

								  `(async-get (async-start ,func)))


								(defun async--fold-left (fn forms bindings)

								  (let ((res forms))

								    (dolist (binding bindings)

								      (setq res (funcall fn res

								                         (if (listp binding)

								                             binding

								                             (list binding)))))

								    res))


								(defmacro async-let (bindings &rest forms)

								  "Implements `let', but each binding is established asynchronously.

								For example:


								  (async-let ((x (foo))

								              (y (bar)))

								     (message \"%s %s\" x y))


								    expands to ==>


								  (async-start (foo)

								   (lambda (x)

								     (async-start (bar)

								      (lambda (y)

								        (message \"%s %s\" x y)))))"

								  (declare (indent 1))

								  (async--fold-left

								   (lambda (acc binding)

								     (let ((fun (pcase (cadr binding)

								                  ((and (pred functionp) f) f)

								                  (f `(lambda () ,f)))))

								       `(async-start ,fun

								                     (lambda (,(car binding))

								                       ,acc))))

								   `(progn ,@forms)

								   (reverse bindings)))


								(provide 'async)


								;;; async.el ends here