diff --git a/README b/README index e245628..09fe1e7 100755 --- a/README +++ b/README @@ -1,14 +1,16 @@ -Kuso IDE - A piece of Shit GNU Emacs based IDE -Copyright (C) 2010-2011 Sameer Rahmani +Kuso IDE +======== +A piece of Shit GNU Emacs based IDE +Copyright (C) 2010-2013 Sameer Rahmani Contents -============================== +-------- 1. License 2. Dependencies 1. License -============================== +---------- Kuso IDE 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 of the License, or @@ -27,28 +29,32 @@ with this program; if not, write to the Free Software Foundation, Inc., under the term of GNU FDL. 2. Dependencies -============================= -Kuso IDE have these prequest softwares: +--------------- +Kuso IDE required these softwares: * GNU Emacs Python dependencies -------------------- -* pep8 -* pyflakes -* pychecker -* pylint +^^^^^^^^^^^^^^^^^^^ + * pep8 + * pyflakes + * pychecker + * pylint + +For autocompetion: + * jedi + * epc HTML dependencies ------------------ -* tidy +^^^^^^^^^^^^^^^^^ + * tidy CSS dependencies ----------------- -* python-cssutils (pip install cssutils) +^^^^^^^^^^^^^^^^ + * python-cssutils (pip install cssutils) 3. Installation -=============== +--------------- Just run install.sh in its directory diff --git a/conf/dotemacs b/conf/dotemacs index b44bda1..55cb1a2 100644 --- a/conf/dotemacs +++ b/conf/dotemacs @@ -19,6 +19,13 @@ (require 'python-mode) (define-key py-mode-map (kbd "\C-c @") 'uncomment-region) +;; python autocomplete +(require 'deferred) +(require 'epc) +(autoload 'jedi:setup "jedi" nil t) +(add-hook 'python-mode-hook 'jedi:setup) +(setq jedi:setup-keys t) + ;; php-mode ------------------------------------------------------------------- (autoload 'php-mode "php-mode" "PHP editing mode" t) (add-to-list 'auto-mode-alist '("\\.php\\'" . php-mode)) diff --git a/conf/dotkuso b/conf/dotkuso index ce3c28a..0aef4bc 100644 --- a/conf/dotkuso +++ b/conf/dotkuso @@ -19,6 +19,13 @@ (require 'python-mode) (define-key py-mode-map (kbd "\C-c @") 'uncomment-region) +;; python autocomplete +(require 'deferred) +(require 'epc) +(autoload 'jedi:setup "jedi" nil t) +(add-hook 'python-mode-hook 'jedi:setup) +(setq jedi:setup-keys t) + ;; php-mode ------------------------------------------------------------------- (autoload 'php-mode "php-mode" "PHP editing mode" t) (add-to-list 'auto-mode-alist '("\\.php\\'" . php-mode)) diff --git a/conf/emacs.d/concurrent.el b/conf/emacs.d/concurrent.el new file mode 100644 index 0000000..4dea73d --- /dev/null +++ b/conf/emacs.d/concurrent.el @@ -0,0 +1,504 @@ +;;; concurrent.el --- Concurrent utility functions for emacs lisp + +;; Copyright (C) 2010, 2011, 2012 SAKURAI Masashi + +;; Author: SAKURAI Masashi +;; Version: 0.3.1 +;; Keywords: deferred, async, concurrent +;; Package-Requires: ((deferred "0.3.1")) +;; URL: https://github.com/kiwanami/emacs-deferred/blob/master/README-concurrent.markdown + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; 'concurrent.el' is a higher level library for concurrent tasks +;; based on 'deferred.el'. This library has following features: +;; +;; - Generator +;; - Green thread +;; - Semaphore +;; - Dataflow +;; - Signal/Channel + +(eval-when-compile + (require 'cl)) + +(require 'deferred) + +(defvar cc:version nil "version number") +(setq cc:version "0.3") + +;;; Code: + + + +(defmacro cc:aif (test-form then-form &rest else-forms) + (declare (debug (form form &rest form))) + `(let ((it ,test-form)) + (if it ,then-form ,@else-forms))) +(put 'cc:aif 'lisp-indent-function 2) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Generator + +(defun cc:generator-replace-yield (tree) + "[internal] Replace `yield' symbols to calling a function in TREE." + (let (ret) + (loop for i in tree + do (cond + ((eq i 'yield) + (push 'funcall ret) + (push i ret)) + ((listp i) + (push (cc:generator-replace-yield i) ret)) + (t + (push i ret)))) + (nreverse ret))) + +(defun cc:generator-line (line) + "[internal] Return a macro expansion to execute the sexp LINE +asynchronously." + (cond + ;; function object + ((functionp line) + `(setq ,chain (deferred:nextc ,chain ,line))) + ;; while loop form + ((eq 'while (car line)) + (let ((condition (cadr line)) + (body (cddr line))) + `(setq ,chain + (deferred:nextc ,chain + (deferred:lambda (x) + (if ,condition + (deferred:nextc + (progn + ,@(cc:generator-replace-yield body)) self))))))) + ;; statement + (t + `(setq ,chain + (deferred:nextc ,chain + (deferred:lambda (x) ,(cc:generator-replace-yield line))))))) + +(defmacro cc:generator (callback &rest body) + "Create a generator object. If BODY has `yield' symbols, it +means calling callback function CALLBACK." + (let ((chain (gensym)) + (cc (gensym)) + (waiter (gensym))) + `(lexical-let* + (,chain + (,cc ,callback) + (,waiter (deferred:new)) + (yield (lambda (x) (funcall ,cc x) ,waiter))) + (setq ,chain ,waiter) + ,@(loop for i in body + collect + (cc:generator-line i)) + (lambda () (deferred:callback ,waiter))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Thread + +(defun cc:thread-line (wait-time chain line) + "[internal] Return a macro expansion to execute the sexp LINE asynchronously. +WAIT-TIME is an interval time between tasks. +CHAIN is the previous deferred task." + (cond + ;; function object + ((functionp line) + `(setq ,chain (deferred:nextc ,chain ,line))) + ;; while loop form + ((eq 'while (car line)) + (let ((condition (cadr line)) + (body (cddr line)) + (retsym (gensym))) + `(setq ,chain + (deferred:nextc ,chain + (deferred:lambda (x) + (if ,condition + (deferred:nextc + (let ((,retsym (progn ,@body))) + (if (deferred-p ,retsym) ,retsym + (deferred:wait ,wait-time))) + self))))))) + ;; statement + (t + `(setq ,chain + (deferred:nextc ,chain + (lambda (x) ,line)))))) + +(defmacro cc:thread (wait-time-msec &rest body) + "Return a thread object." + (let ((chain (gensym)) + (dstart (gensym))) + `(lexical-let* + (,chain + (,dstart (deferred:new))) + (setq ,chain ,dstart) + ,@(loop for i in body + collect + (cc:thread-line wait-time-msec chain i)) + (deferred:callback ,dstart)))) +(put 'cc:thread 'lisp-indent-function 1) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Semaphore + +(defstruct cc:semaphore max-permits permits waiting-deferreds) + +(defun cc:semaphore-create(permits-num) + "Return a semaphore object with PERMITS-NUM permissions." + (make-cc:semaphore :max-permits permits-num :permits permits-num)) + +(defun cc:semaphore-acquire(semaphore) + "Acquire an execution permission and return deferred object to chain. +If this semaphore object has permissions, the subsequent deferred +task is executed immediately. If this semaphore object has no +permissions, the subsequent deferred task is blocked. After the +permission is returned, the task is executed." + (cond + ((< 0 (cc:semaphore-permits semaphore)) + (decf (cc:semaphore-permits semaphore)) + (deferred:succeed)) + (t + (let ((d (deferred:new))) + (push d (cc:semaphore-waiting-deferreds semaphore)) + d)))) + +(defun cc:semaphore-release(semaphore) + "Release an execution permission. The programmer is responsible to return the permissions." + (when (<= (cc:semaphore-max-permits semaphore) + (cc:semaphore-permits semaphore)) + (error "Too many calling semaphore-release. [max:%s <= permits:%s]" + (cc:semaphore-max-permits semaphore) + (cc:semaphore-permits semaphore))) + (let ((waiting-deferreds + (cc:semaphore-waiting-deferreds semaphore))) + (cond + (waiting-deferreds + (let* ((d (car (last waiting-deferreds)))) + (setf (cc:semaphore-waiting-deferreds semaphore) + (nbutlast waiting-deferreds)) + (deferred:callback-post d))) + (t + (incf (cc:semaphore-permits semaphore))))) + semaphore) + +(defun cc:semaphore-with (semaphore body-func &optional error-func) + "Execute the task BODY-FUNC asynchronously with the semaphore block." + (lexical-let ((semaphore semaphore)) + (deferred:try + (deferred:nextc (cc:semaphore-acquire semaphore) body-func) + :catch + error-func + :finally + (lambda (x) (cc:semaphore-release semaphore))))) +(put 'cc:semaphore-with 'lisp-indent-function 1) + +(defun cc:semaphore-release-all (semaphore) + "Release all permissions for resetting the semaphore object. +If the semaphore object has some blocked tasks, this function +return a list of the tasks and clear the list of the blocked +tasks in the semaphore object." + (setf (cc:semaphore-permits semaphore) + (cc:semaphore-max-permits semaphore)) + (let ((ds (cc:semaphore-waiting-deferreds semaphore))) + (when ds + (setf (cc:semaphore-waiting-deferreds semaphore) nil)) + ds)) + +(defun cc:semaphore-interrupt-all (semaphore) + "Clear the list of the blocked tasks in the semaphore and return a deferred object to chain. +This function is used for the interruption cases." + (when (cc:semaphore-waiting-deferreds semaphore) + (setf (cc:semaphore-waiting-deferreds semaphore) nil) + (setf (cc:semaphore-permits semaphore) 0)) + (cc:semaphore-acquire semaphore)) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Signal / Channel + +(defun cc:signal-channel (&optional name parent-channel) + "Create a channel. +NAME is a channel name for debug. +PARENT-CHANNEL is an upstream channel. The observers of this channel can receive the upstream signals. +In the case of using the function `cc:signal-send', the observers of the upstream channel can not receive the signals of this channel. The function `cc:signal-send-global' can send a signal to the upstream channels from the downstream channels." + (lexical-let + ((ch (cons + (or name (format "signal%s" (deferred:uid))) ; name for debug + (cons + parent-channel ; parent-channel + nil)))) ; observers + (when parent-channel + (cc:signal-connect + parent-channel + t (lambda (event) + (destructuring-bind + (event-name event-args) event + (apply 'cc:signal-send + ch event-name event-args))))) + ch)) + +(defmacro cc:signal-name (ch) + "[internal] Return signal name." + `(car ,ch)) + +(defmacro cc:signal-parent-channel (ch) + "[internal] Return parent channel object." + `(cadr ,ch)) + +(defmacro cc:signal-observers (ch) + "[internal] Return observers." + `(cddr ,ch)) + +(defun cc:signal-connect (channel event-sym &optional callback) + "Append an observer for EVENT-SYM of CHANNEL and return a deferred object. +If EVENT-SYM is `t', the observer receives all signals of the channel. +If CALLBACK function is given, the deferred object executes the +CALLBACK function asynchronously. One can connect subsequent +tasks to the returned deferred object." + (let ((d (if callback + (deferred:new callback) + (deferred:new)))) + (push (cons event-sym d) + (cc:signal-observers channel)) + d)) + +(defun cc:signal-send (channel event-sym &rest args) + "Send a signal to CHANNEL. If ARGS values are given, observers can get the values by following code: (lambda (event) (destructuring-bind (event-sym (args)) event ... )). " + (let ((observers (cc:signal-observers channel)) + (event (list event-sym args))) + (loop for i in observers + for name = (car i) + for d = (cdr i) + if (or (eq event-sym name) (eq t name)) + do (deferred:callback-post d event)))) + +(defun cc:signal-send-global (channel event-sym &rest args) + "Send a signal to the most upstream channel. " + (cc:aif (cc:signal-parent-channel channel) + (apply 'cc:signal-send-global it event-sym args) + (apply 'cc:signal-send channel event-sym args))) + + +(defun cc:signal-disconnect (channel deferred) + "Remove the observer object DEFERRED from CHANNEL and return +the removed deferred object. " + (let ((observers (cc:signal-observers channel)) deleted) + (setf + (cc:signal-observers channel) ; place + (loop for i in observers + for d = (cdr i) + unless (eq d deferred) + collect i + else + do (push i deleted))) + deleted)) + +(defun cc:signal-disconnect-all (channel) + "Remove all observers." + (setf + (cc:signal-observers channel) ; place + nil)) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Dataflow + +;; Dataflow variable entry +(defstruct cc:dataflow key (value 'cc:dataflow-undefine) deferred-list) + +(defun cc:dataflow-undefine-p (obj) + "[internal] If the variable entry is not bound, return `t'." + (eq 'cc:dataflow-undefine (cc:dataflow-value obj))) + +(defun cc:dataflow-environment (&optional parent-env test-func channel) + "Create a dataflow environment. +PARENT-ENV is the default environment. If this environment doesn't have the entry A and the parent one has the entry A, this environment can return the entry A. One can override the entry, setting another entry A to this environment. +TEST-FUNC is a test function that compares the entry keys. The default function is `equal'. +CHANNEL is a channel object that sends signals of variable events. Observers can receive following signals: +-get-first : the fist referrer is waiting for binding, +-get-waiting : another referrer is waiting for binding, +-set : a value is bound, +-get : returned a bound value, +-clear : cleared one entry, +-clear-all : cleared all entries. +" + (let ((this (list parent-env + (or test-func 'equal) + (or channel + (cc:signal-channel + 'dataflow + (and parent-env + (cc:dataflow-channel parent-env))))))) + (cc:dataflow-init-connect this) + this)) + +(defun cc:dataflow-init-connect (df) + "[internal] Initialize the channel object." + (lexical-let ((df df)) + (cc:dataflow-connect + df 'set + (lambda (args) + (destructuring-bind (event (key)) args + (let* ((obj (cc:dataflow-get-object-for-value df key)) + (value (and obj (cc:dataflow-value obj)))) + (when obj + (loop for i in (cc:aif (cc:dataflow-get-object-for-deferreds df key) + (cc:dataflow-deferred-list it) nil) + do (deferred:callback-post i value)) + (setf (cc:dataflow-deferred-list obj) nil)))))))) + +(defmacro cc:dataflow-parent-environment (df) + "[internal] Return the parent environment." + `(car ,df)) + +(defmacro cc:dataflow-test (df) + "[internal] Return the test function." + `(cadr ,df)) + +(defmacro cc:dataflow-channel (df) + "[internal] Return the channel object." + `(caddr ,df)) + +(defmacro cc:dataflow-list (df) + "[internal] Return the list of deferred object which are waiting for value binding." + `(cdddr ,df)) + +(defun cc:dataflow-get-object-for-value (df key) + "[internal] Return an entry object that is indicated by KEY. +If the environment DF doesn't have the entry and the parent one has the entry, this function returns the entry of the parent environment. This function doesn't affect the waiting list." + (or + (loop for i in (cc:dataflow-list df) + with test = (cc:dataflow-test df) + if (and (funcall test key (cc:dataflow-key i)) + (not (cc:dataflow-undefine-p i))) + return i) + (deferred:aand + (cc:dataflow-parent-environment df) + (cc:dataflow-get-object-for-value it key)))) + +(defun cc:dataflow-get-object-for-deferreds (df key) + "[internal] Return a list of the deferred objects those are waiting for value binding. +This function doesn't affect the waiting list and doesn't refer the parent environment." + (loop for i in (cc:dataflow-list df) + with test = (cc:dataflow-test df) + if (funcall test key (cc:dataflow-key i)) + return i)) + +(defun cc:dataflow-connect (df event-sym &optional callback) + "Append an observer for EVENT-SYM of the channel of DF and return a deferred object. +See the docstring of `cc:dataflow-environment' for details." + (cc:signal-connect (cc:dataflow-channel df) event-sym callback)) + +(defun cc:dataflow-signal (df event &optional arg) + "[internal] Send a signal to the channel of DF." + (cc:signal-send (cc:dataflow-channel df) event arg)) + +(defun cc:dataflow-get (df key) + "Return a deferred object that can refer the value which is indicated by KEY. +If DF has the entry that bound value, the subsequent deferred task is executed immediately. +If not, the task is deferred till a value is bound." + (let ((obj (cc:dataflow-get-object-for-value df key))) + (cond + ((and obj (cc:dataflow-value obj)) + (cc:dataflow-signal df 'get key) + (deferred:succeed (cc:dataflow-value obj))) + (t + (setq obj (cc:dataflow-get-object-for-deferreds df key)) + (unless obj + (setq obj (make-cc:dataflow :key key)) + (push obj (cc:dataflow-list df)) + (cc:dataflow-signal df 'get-first key)) + (let ((d (deferred:new))) + (push d (cc:dataflow-deferred-list obj)) + (cc:dataflow-signal df 'get-waiting key) + d))))) + +(defun cc:dataflow-get-sync (df key) + "Return the value which is indicated by KEY synchronously. +If the environment DF doesn't have an entry of KEY, this function returns nil." + (let ((obj (cc:dataflow-get-object-for-value df key))) + (and obj (cc:dataflow-value obj)))) + +(defun cc:dataflow-set (df key value) + "Bind the VALUE to KEY in the environment DF. +If DF already has the bound entry of KEY, this function throws an error signal. +VALUE can be nil as a value." + (let ((obj (cc:dataflow-get-object-for-deferreds df key))) + (cond + ((and obj (not (cc:dataflow-undefine-p obj))) + ;; overwrite! + (error "Can not set a dataflow value. The key [%s] has already had a value. NEW:[%s] OLD:[%s]" key value (cc:dataflow-value obj))) + (obj + (setf (cc:dataflow-value obj) value)) + (t + ;; just value arrived + (push (make-cc:dataflow :key key :value value) + (cc:dataflow-list df)))) + ;; value arrived and start deferred objects + (cc:dataflow-signal df 'set key) + value)) + +(defun cc:dataflow-clear (df key) + "Clear the entry which is indicated by KEY. +This function does nothing for the waiting deferred objects." + (cc:dataflow-signal df 'clear key) + (setf (cc:dataflow-list df) + (loop for i in (cc:dataflow-list df) + with test = (cc:dataflow-test df) + unless (funcall test key (cc:dataflow-key i)) + collect i))) + +(defun cc:dataflow-get-avalable-pairs (df) + "Return an available key-value alist in the environment DF and the parent ones." + (append + (loop for i in (cc:dataflow-list df) + for key = (cc:dataflow-key i) + for val = (cc:dataflow-value i) + unless (cc:dataflow-undefine-p i) collect (cons key val)) + (deferred:aand + (cc:dataflow-parent-environment df) + (cc:dataflow-get-avalable-pairs it)))) + +(defun cc:dataflow-get-waiting-keys (df) + "Return a list of keys which have waiting deferred objects in the environment DF and the parent ones." + (append + (loop for i in (cc:dataflow-list df) + for key = (cc:dataflow-key i) + for val = (cc:dataflow-value i) + if (cc:dataflow-undefine-p i) collect key) + (deferred:aand + (cc:dataflow-parent-environment df) + (cc:dataflow-get-waiting-keys it)))) + +(defun cc:dataflow-clear-all (df) + "Clear all entries in the environment DF. +This function does nothing for the waiting deferred objects." + (cc:dataflow-signal df 'clear-all) + (setf (cc:dataflow-list df) nil)) + + +(provide 'concurrent) +;;; concurrent.el ends here + diff --git a/conf/emacs.d/ctable.el b/conf/emacs.d/ctable.el new file mode 100644 index 0000000..f81866d --- /dev/null +++ b/conf/emacs.d/ctable.el @@ -0,0 +1,1588 @@ +;;; ctable.el --- Table component for Emacs Lisp + +;; Copyright (C) 2011,2012,2013 SAKURAI Masashi + +;; Author: SAKURAI Masashi +;; URL: https://github.com/kiwanami/emacs-ctable +;; Version: 0.1.1 +;; Keywords: table + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This program is a table component for Emacs Lisp. +;; Other programs can use this table component for the application UI. + +;;; Installation: + +;; Place this program in your load path and add following code. + +;; (require 'ctable) + +;;; Usage: + +;; Executing the command `ctbl:open-table-buffer', switch to the table buffer. + +;; Table data which are shown in the table view, are collected +;; by the `ctbl:model' objects. See the function `ctbl:demo' for example. + +;;; Code: + +(eval-when-compile (require 'cl)) + + +;;; Models and Parameters + +;; ctbl:model / table model structure +;; +;; data : Table data as a list of rows. A row contains a list of columns. +;; column-model : A list of column models. +;; sort-state : The current sort order as a list of column indexes. +;; The index number of the first column is 1. +;; If the index is negative, the sort order is reversed. + +(defstruct ctbl:model data column-model sort-state) + +;; ctbl:cmodel / table column model structure +;; +;; title : title string. +;; sorter : sorting function which transforms a cell value into sort value. +;; It should return -1, 0 and 1. If nil, `ctbl:sort-string-lessp' is used. +;; align : text alignment: 'left, 'right and 'center. (default: right) +;; max-width : maximum width of the column. if nil, no constraint. (default: nil) +;; min-width : minimum width of the column. if nil, no constraint. (default: nil) +;; click-hooks : a list of functions for header clicking with two arguments +;; the `ctbl:component' object and the `ctbl:cmodel' one. +;; (default: '(`ctbl:cmodel-sort-action')) + +(defstruct ctbl:cmodel title sorter align max-width min-width + (click-hooks '(ctbl:cmodel-sort-action))) + +;; ctbl:param / rendering parameters +;; + +(defstruct ctbl:param + display-header ;; if t, display the header row with column models. + fixed-header ;; if t, display the header row in the header-line area. + bg-colors ;; '(((row-id . col-id) . colorstr) (t . default-color) ... ) or (lambda (model row-id col-id) colorstr or nil) + vline-colors ;; "#RRGGBB" or '((0 . colorstr) (t . default-color)) or (lambda (model col-index) colorstr or nil) + hline-colors ;; "#RRGGBB" or '((0 . colorstr) (t . default-color)) or (lambda (model row-index) colorstr or nil) + draw-vlines ;; 'all or '(0 1 2 .. -1) or (lambda (model col-index) t or nil ) + draw-hlines ;; 'all or '(0 1 2 .. -1) or (lambda (model row-index) t or nil ) + vertical-line horizontal-line ;; | - + left-top-corner right-top-corner left-bottom-corner right-bottom-corner ;; + + top-junction bottom-junction left-junction right-junction cross-junction ;; + + ) + +(defvar ctbl:default-rendering-param + (make-ctbl:param + :display-header t + :fixed-header nil + :bg-colors nil + :vline-colors "DarkGray" + :hline-colors "DarkGray" + :draw-vlines 'all + :draw-hlines '(1) + :vertical-line ?| + :horizontal-line ?- + :left-top-corner ?+ + :right-top-corner ?+ + :left-bottom-corner ?+ + :right-bottom-corner ?+ + :top-junction ?+ + :bottom-junction ?+ + :left-junction ?+ + :right-junction ?+ + :cross-junction ?+ + ) + "Default rendering parameters.") + +(defvar ctbl:tooltip-method '(pos-tip popup minibuffer) + "Preferred tooltip methods in order.") + +;;; Faces + +(defface ctbl:face-row-select + '((((class color) (background light)) + :background "WhiteSmoke") + (((class color) (background dark)) + :background "Blue4")) + "Face for row selection" :group 'ctable) + +(defface ctbl:face-cell-select + '((((class color) (background light)) + :background "Mistyrose1") + (((class color) (background dark)) + :background "Blue2")) + "Face for cell selection" :group 'ctable) + +(defface ctbl:face-continue-bar + '((((class color) (background light)) + :background "OldLace") + (((class color) (background dark)) + :background "Gray26")) + "Face for continue bar" :group 'ctable) + +;;; Utilities + +(defun ctbl:define-keymap (keymap-list &optional prefix) + "[internal] Keymap utility." + (let ((map (make-sparse-keymap))) + (mapc + (lambda (i) + (define-key map + (if (stringp (car i)) + (read-kbd-macro + (if prefix + (replace-regexp-in-string "prefix" prefix (car i)) + (car i))) + (car i)) + (cdr i))) + keymap-list) + map)) + +(defun ctbl:cell-id (row-id col-id) + "[internal] Create a cell-id object" + (cons row-id col-id)) + +(defun ctbl:tp (text prop value) + "[internal] Put a text property to the entire text string." + (if (< 0 (length text)) + (put-text-property 0 (length text) prop value text)) + text) + +(defvar ctbl:uid 1) + +(defun ctbl:uid () + "[internal] Generate an unique number." + (incf ctbl:uid)) + +(defun ctbl:fill-keymap-property (begin end keymap) + "[internal] Put the given text property to the region between BEGIN and END. +If the text already has some keymap property, the text is skipped." + (save-excursion + (goto-char begin) + (loop with pos = begin with nxt = nil + until (or (null pos) (<= end pos)) + when (get-text-property pos 'keymap) do + (setq pos (next-single-property-change pos 'keymap)) + else do + (setq nxt (next-single-property-change pos 'keymap)) + (when (null nxt) (setq nxt end)) + (put-text-property pos (min nxt end) 'keymap keymap)))) + +;; Model functions + +(defun ctbl:model-column-length (model) + "[internal] Return the column number." + (length (car (ctbl:model-data model)))) + +(defun ctbl:model-row-length (model) + "[internal] Return the row number." + (length (ctbl:model-data model))) + +(defun ctbl:model-modify-sort-key (model col-index) + "Modify the list of sort keys for the column headers." + (let* ((sort-keys (ctbl:model-sort-state model)) + (col-key (1+ col-index))) + (cond + ((eq (car sort-keys) col-key) + (setf (ctbl:model-sort-state model) + (cons (- col-key) (cdr sort-keys)))) + ((eq (car sort-keys) (- col-key)) + (setf (ctbl:model-sort-state model) + (cons col-key (cdr sort-keys)))) + (t + (setf (ctbl:model-sort-state model) + (cons col-key (delete (- col-key) + (delete col-key sort-keys)))))) + (ctbl:model-sort-state model))) + +(defun ctbl:cmodel-sort-action (cp col-index) + "Sorting action for click on the column headers" + (let* ((model (ctbl:cp-get-model cp))) + (ctbl:model-modify-sort-key model col-index) + (ctbl:cp-update cp))) + + +;;; Structures + +;; Component + +;; This structure defines attributes of the table component. +;; These attributes are internal use. Other programs should access +;; through the functions of the component interface. + +;; [ctbl:component] +;; dest : an object of `ctbl:dest' +;; model : an object of the table model +;; selected : selected cell-id: (row index . col index) +;; param : rendering parameter object +;; sorted-data : sorted data to display the table view. +;; see `ctbl:cp-get-selected-data-row' and `ctbl:cp-get-selected-data-cell'. +;; update-hooks : a list of hook functions for update event +;; selection-change-hooks : a list of hook functions for selection change event +;; click-hooks : a list of hook functions for click event + +(defstruct ctbl:component dest model param selected sorted-data + update-hooks selection-change-hooks click-hooks) + + +;; Rendering Destination + +;; This structure object is the abstraction of the rendering +;; destinations, such as buffers, regions and so on. + +;; [ctbl:dest] +;; type : identify symbol for destination type. (buffer, region, text) +;; buffer : a buffer object of rendering destination. +;; min-func : a function that returns upper limit of rendering destination. +;; max-func : a function that returns lower limit of rendering destination. +;; width : width of the reference size. (number, nil or full) +;; height : height of the reference size. (number, nil or full) +;; clear-func : a function that clears the rendering destination. +;; before-update-func : a function that is called at the beginning of rendering routine. +;; after-update-func : a function that is called at the end of rendering routine. +;; select-ol : a list of overlays for selection + +(defstruct ctbl:dest + type buffer min-func max-func width height + clear-func before-update-func after-update-func select-ol) + +(eval-when-compile + (defmacro ctbl:dest-with-region (dest &rest body) + (declare (debug (form &rest form))) + (let (($dest (gensym))) + `(let ((,$dest ,dest)) + (with-current-buffer (ctbl:dest-buffer ,$dest) + (save-restriction + (narrow-to-region + (ctbl:dest-point-min ,$dest) (ctbl:dest-point-max ,$dest)) + ,@body)))))) +(put 'ctbl:dest-with-region 'lisp-indent-function 1) + +(defun ctbl:dest-point-min (c) + (funcall (ctbl:dest-min-func c))) + +(defun ctbl:dest-point-max (c) + (funcall (ctbl:dest-max-func c))) + +(defun ctbl:dest-clear (c) + (funcall (ctbl:dest-clear-func c))) + +(defun ctbl:dest-before-update (c) + (when (ctbl:dest-before-update-func c) + (funcall (ctbl:dest-before-update-func c)))) + +(defun ctbl:dest-after-update (c) + (when (ctbl:dest-after-update-func c) + (funcall (ctbl:dest-after-update-func c)))) + + +;; Buffer + +(defconst ctbl:table-buffer-name "*ctbl-table*" "[internal] Default buffer name for the table view.") + +(defun ctbl:dest-init-buffer (&optional buf width height custom-map) + "Create a buffer destination. +This destination uses an entire buffer and set up the major-mode +`ctbl:table-mode' and the key map `ctbl:table-mode-map'. BUF is +a buffer name to render the table view. If BUF is nil, the +default buffer name is used. WIDTH and HEIGHT are reference size +of the table view. If those are nil, the size of table is +calculated from the window that shows BUF or the selected window. +The component object is stored at the buffer local variable +`ctbl:component'. CUSTOM-MAP is the additional keymap that is +added to default keymap `ctbl:table-mode-map'." + (lexical-let + ((buffer (or buf (get-buffer-create (format "*Table: %d*" (ctbl:uid))))) + (window (or (and buf (get-buffer-window buf)) (selected-window))) + dest) + (setq dest + (make-ctbl:dest + :type 'buffer + :min-func 'point-min + :max-func 'point-max + :buffer buffer + :width width + :height height + :clear-func (lambda () + (with-current-buffer buffer + (erase-buffer))))) + (with-current-buffer buffer + (unless (eq major-mode 'ctbl:table-mode) + (ctbl:table-mode custom-map))) + dest)) + +;; Region + +(defun ctbl:dest-init-region (buf mark-begin mark-end &optional width height) + "Create a region destination. The table is drew between +MARK-BEGIN and MARK-END in the buffer BUF. MARK-BEGIN and +MARK-END are separated by more than one character, such as a +space. This destination is employed to be embedded in the some +application buffer. Because this destination does not set up +any modes and key maps for the buffer, the application that uses +the calfw is responsible to manage the buffer and key maps." + (lexical-let + ((mark-begin mark-begin) (mark-end mark-end) + (window (or (get-buffer-window buf) (selected-window)))) + (make-ctbl:dest + :type 'region + :min-func (lambda () (marker-position mark-begin)) + :max-func (lambda () (marker-position mark-end)) + :buffer buf + :width width + :height height + :clear-func + (lambda () + (ctbl:dest-region-clear (marker-position mark-begin) + (marker-position mark-end))) + ))) + +(defun ctbl:dest-region-clear (begin end) + "[internal] Clear the content text." + (when (< 2 (- end begin)) + (delete-region begin (1- end))) + (goto-char begin)) + +;; Inline text + +(defconst ctbl:dest-background-buffer " *ctbl:dest-background*") + +(defun ctbl:dest-init-inline (width height) + "Create a text destination." + (lexical-let + ((buffer (get-buffer-create ctbl:dest-background-buffer)) + (window (selected-window)) + dest) + (setq dest + (make-ctbl:dest + :type 'text + :min-func 'point-min + :max-func 'point-max + :buffer buffer + :width width + :height height + :clear-func (lambda () + (with-current-buffer buffer + (erase-buffer))))) + dest)) + +;; private functions + +(defun ctbl:dest-ol-selection-clear (dest) + "[internal] Clear the selection overlays on the current table view." + (loop for i in (ctbl:dest-select-ol dest) + do (delete-overlay i)) + (setf (ctbl:dest-select-ol dest) nil)) + +(defun ctbl:dest-ol-selection-set (dest cell-id) + "[internal] Put a selection overlay on CELL-ID. The selection overlay can be + put on some cells, calling this function many times. This + function does not manage the selections, just put the overlay." + (lexical-let (ols (row-id (car cell-id)) (col-id (cdr cell-id))) + (ctbl:dest-with-region dest + (ctbl:find-all-by-row-id + dest row-id + (lambda (tcell-id begin end) + (let ((overlay (make-overlay begin end))) + (overlay-put overlay 'face + (if (= (cdr tcell-id) col-id) + 'ctbl:face-cell-select + 'ctbl:face-row-select)) + (push overlay ols))))) + (setf (ctbl:dest-select-ol dest) ols))) + + +;; Component + +(defun ctbl:cp-new (dest model param) + "[internal] Create a new component object. +DEST is a ctbl:dest object. MODEL is a model object. PARAM is a +rendering parameter object. This function is called by the +initialization functions, `ctbl:create-table-component-buffer', +`ctbl:create-table-component-region' and `ctbl:get-table-text'." + (let ((cp (make-ctbl:component + :selected '(0 . 0) + :dest dest + :model model + :param (or param ctbl:default-rendering-param)))) + (ctbl:cp-update cp) + cp)) + +(defun ctbl:cp-get-component () + "Return the component object on the current cursor position. +Firstly, getting a text property `ctbl:component' on the current +position. If no object is found in the text property, the buffer +local variable `ctbl:component' is tried to get. If no object is +found at the variable, return nil." + (let ((component (get-text-property (point) 'ctbl:component))) + (unless component + (unless (local-variable-p 'ctbl:component (current-buffer)) + (error "Not found ctbl:component attribute...")) + (setq component (buffer-local-value 'ctbl:component (current-buffer)))) + component)) + +;; Component : getters + +(defun ctbl:cp-get-selected (component) + "Return the selected cell-id of the component." + (ctbl:component-selected component)) + +(defun ctbl:cp-get-selected-data-row (component) + "Return the selected row data. If no cell is selected, return nil." + (let* ((rows (ctbl:component-sorted-data component)) + (cell-id (ctbl:component-selected component)) + (row-id (car cell-id)) (col-id (cdr cell-id))) + (if row-id (nth row-id rows) nil))) + +(defun ctbl:cp-get-selected-data-cell (component) + "Return the selected cell data. If no cell is selected, return nil." + (let* ((rows (ctbl:component-sorted-data component)) + (cell-id (ctbl:component-selected component)) + (row-id (car cell-id)) (col-id (cdr cell-id))) + (if row-id + (nth col-id (nth row-id rows)) + nil))) + +(defun ctbl:cp-get-model (component) + "Return the model object." + (ctbl:component-model component)) + +(defun ctbl:cp-get-param (component) + "Return a rendering parameter object." + (ctbl:component-param component)) + +(defun ctbl:cp-get-buffer (component) + "Return a buffer object on which the component draws the content." + (ctbl:dest-buffer (ctbl:component-dest component))) + +;; Component : setters + +(defun ctbl:cp-move-cursor (dest cell-id) + "[internal] Just move the cursor onto the CELL-ID. +If CELL-ID is not found, return nil. This function +is called by `ctbl:cp-set-selected-cell'." + (let ((pos (ctbl:find-by-cell-id dest cell-id))) + (cond + (pos + (goto-char pos) + (unless (eql (selected-window) (get-buffer-window (current-buffer))) + (set-window-point (get-buffer-window (current-buffer)) pos)) + t) + (t nil)))) + +(defun ctbl:cp-set-selected-cell (component cell-id) + "Select the cell on the component. If the current view doesn't contain the cell, +this function updates the view to display the cell." + (let ((last (ctbl:component-selected component)) + (dest (ctbl:component-dest component)) + (model (ctbl:component-model component))) + (when (ctbl:cp-move-cursor dest cell-id) + (setf (ctbl:component-selected component) cell-id) + (ctbl:dest-before-update dest) + (ctbl:dest-ol-selection-clear dest) + (ctbl:dest-ol-selection-set dest cell-id) + (ctbl:dest-after-update dest) + (unless (equal last cell-id) + (ctbl:cp-fire-selection-change-hooks component))))) + +;; Hook + +(defun ctbl:cp-add-update-hook (component hook) + "Add the update hook function to the component. +HOOK is a function that has no argument." + (push hook (ctbl:component-update-hooks component))) + +(defun ctbl:cp-add-selection-change-hook (component hook) + "Add the selection change hook function to the component. +HOOK is a function that has no argument." + (push hook (ctbl:component-selection-change-hooks component))) + +(defun ctbl:cp-add-click-hook (component hook) + "Add the click hook function to the component. +HOOK is a function that has no argument." + (push hook (ctbl:component-click-hooks component))) + +;; Component : privates + +(defun ctbl:cp-update (component) + "[internal] Clear and re-draw the component content." + (let* ((buf (ctbl:cp-get-buffer component)) + (dest (ctbl:component-dest component))) + (with-current-buffer buf + (ctbl:dest-before-update dest) + (ctbl:dest-ol-selection-clear dest) + (let (buffer-read-only) + (ctbl:dest-with-region dest + (ctbl:dest-clear dest) + (setf (ctbl:component-sorted-data component) + (ctbl:render-main + dest + (ctbl:component-model component) + (ctbl:component-param component))))) + (ctbl:cp-set-selected-cell + component (ctbl:component-selected component)) + (ctbl:dest-after-update dest) + (ctbl:cp-fire-update-hooks component)))) + +(defun ctbl:cp-fire-click-hooks (component) + "[internal] Call click hook functions of the component with no arguments." + (loop for f in (ctbl:component-click-hooks component) + do (condition-case err + (funcall f) + (error (message "CTable: Click / Hook error %S [%s]" f err))))) + +(defun ctbl:cp-fire-selection-change-hooks (component) + "[internal] Call selection change hook functions of the component with no arguments." + (loop for f in (ctbl:component-selection-change-hooks component) + do (condition-case err + (funcall f) + (error (message "CTable: Selection change / Hook error %S [%s]" f err))))) + +(defun ctbl:cp-fire-update-hooks (component) + "[internal] Call update hook functions of the component with no arguments." + (loop for f in (ctbl:component-update-hooks component) + do (condition-case err + (funcall f) + (error (message "Ctable: Update / Hook error %S [%s]" f err))))) + + +(defun ctbl:find-by-cell-id (dest cell-id) + "[internal] Return a point where the text property `ctbl:cell-id' +is equal to cell-id in the current table view. If CELL-ID is not +found in the current view, return nil." + (loop with pos = (ctbl:dest-point-min dest) + with end = (ctbl:dest-point-max dest) + for next = (next-single-property-change pos 'ctbl:cell-id nil end) + for text-cell = (and next (ctbl:cursor-to-cell next)) + while (and next (< next end)) do + (if (and text-cell (equal cell-id text-cell)) + (return next)) + (setq pos next))) + +(defun ctbl:find-all-by-cell-id (dest cell-id func) + "[internal] Call the function FUNC in each regions where the +text-property `ctbl:cell-id' is equal to CELL-ID. The argument function FUNC +receives two arguments, begin position and end one. This function is +mainly used at functions for putting overlays." + (loop with pos = (ctbl:dest-point-min dest) + with end = (ctbl:dest-point-max dest) + for next = (next-single-property-change pos 'ctbl:cell-id nil end) + for text-id = (and next (ctbl:cursor-to-cell next)) + while (and next (< next end)) do + (if (and text-id (equal cell-id text-id)) + (let ((cend (next-single-property-change + next 'ctbl:cell-id nil end))) + (funcall func next cend))) + (setq pos next))) + +(defun ctbl:find-all-by-row-id (dest row-id func) + "[internal] Call the function FUNC in each regions where the +row-id of the text-property `ctbl:cell-id' is equal to +ROW-ID. The argument function FUNC receives three arguments, +cell-id, begin position and end one. This function is mainly used +at functions for putting overlays." + (loop with pos = (ctbl:dest-point-min dest) + with end = (ctbl:dest-point-max dest) + for next = (next-single-property-change pos 'ctbl:cell-id nil end) + for text-id = (and next (ctbl:cursor-to-cell next)) + while (and next (< next end)) do + (if (and text-id (equal row-id (car text-id))) + (let ((cend (next-single-property-change + next 'ctbl:cell-id nil end))) + (funcall func text-id next cend))) + (setq pos next))) + +(defun ctbl:find-first-cell (dest) + "[internal] Return the first cell in the current buffer." + (let ((pos (next-single-property-change + (ctbl:dest-point-min dest) 'ctbl:cell-id))) + (and pos (ctbl:cursor-to-cell pos)))) + +(defun ctbl:find-last-cell (dest) + "[internal] Return the last cell in the current buffer." + (let ((pos (previous-single-property-change + (ctbl:dest-point-max dest) 'ctbl:cell-id))) + (and pos (ctbl:cursor-to-cell (1- pos))))) + +(defun ctbl:cursor-to-cell (&optional pos) + "[internal] Return the cell-id at the cursor. If the text does not +have the text-property `ctbl:cell-id', return nil." + (get-text-property (or pos (point)) 'ctbl:cell-id)) + +(defun ctbl:cursor-to-nearest-cell () + "Return the cell-id at the cursor. If the point of cursor does +not have the cell-id, search the cell-id around the cursor +position. If the current buffer is not table view (it may be +bug), this function may return nil." + (or (ctbl:cursor-to-cell) + (let* ((r (lambda () (when (not (eolp)) (forward-char)))) + (l (lambda () (when (not (bolp)) (backward-char)))) + (u (lambda () (when (not (bobp)) (line-move 1)))) + (d (lambda () (when (not (eobp)) (line-move -1)))) + (dest (ctbl:component-dest (ctbl:cp-get-component))) + get) + (setq get (lambda (cmds) + (save-excursion + (if (null cmds) (ctbl:cursor-to-cell) + (ignore-errors + (funcall (car cmds)) (funcall get (cdr cmds))))))) + (or (loop for i in `((,d) (,r) (,u) (,l) + (,d ,r) (,d ,l) (,u ,r) (,u ,l) + (,d ,d) (,r ,r) (,u ,u) (,l ,l)) + for id = (funcall get i) + if id return id) + (cond + ((> (/ (point-max) 2) (point)) + (ctbl:find-first-cell dest)) + (t (ctbl:find-last-cell dest))))))) + + +;; Commands + +(defun ctbl:navi-move-gen (drow dcol) + "[internal] Move to the cell with the abstract position." + (let* ((cp (ctbl:cp-get-component)) + (cell-id (ctbl:cursor-to-nearest-cell)) + (row-id (car cell-id)) (col-id (cdr cell-id))) + (when (and cp cell-id) + (ctbl:navi-goto-cell (ctbl:cell-id (+ drow row-id) + (+ dcol col-id)))))) + +(defun ctbl:navi-move-up (&optional num) + "Move to the up neighbor cell." + (interactive "p") + (unless num (setq num 1)) + (ctbl:navi-move-gen (- num) 0)) + +(defun ctbl:navi-move-down (&optional num) + "Move to the down neighbor cell." + (interactive "p") + (unless num (setq num 1)) + (ctbl:navi-move-gen num 0)) + +(defun ctbl:navi-move-right (&optional num) + "Move to the right neighbor cell." + (interactive "p") + (unless num (setq num 1)) + (ctbl:navi-move-gen 0 num)) + +(defun ctbl:navi-move-left (&optional num) + "Move to the left neighbor cell." + (interactive "p") + (unless num (setq num 1)) + (ctbl:navi-move-gen 0 (- num))) + +(defun ctbl:navi-move-left-most () + "Move to the left most cell." + (interactive) + (let* ((cp (ctbl:cp-get-component)) + (cell-id (ctbl:cursor-to-nearest-cell)) + (row-id (car cell-id))) + (when (and cp cell-id) + (ctbl:navi-goto-cell (ctbl:cell-id row-id 0))))) + +(defun ctbl:navi-move-right-most () + "Move to the right most cell." + (interactive) + (let* ((cp (ctbl:cp-get-component)) + (cell-id (ctbl:cursor-to-nearest-cell)) + (row-id (car cell-id)) + (model (ctbl:cp-get-model cp)) + (cols (ctbl:model-column-length model))) + (when (and cp cell-id) + (ctbl:navi-goto-cell (ctbl:cell-id row-id (1- cols)))))) + +(defun ctbl:navi-goto-cell (cell-id) + "Move the cursor to CELL-ID and put selection." + (let ((cp (ctbl:cp-get-component))) + (when cp + (ctbl:cp-set-selected-cell cp cell-id)))) + +(defun ctbl:navi-on-click () + "Action handler on the cells." + (interactive) + (let ((cp (ctbl:cp-get-component)) + (cell-id (ctbl:cursor-to-nearest-cell))) + (when (and cp cell-id) + (ctbl:cp-set-selected-cell cp cell-id) + (ctbl:cp-fire-click-hooks cp)))) + +(defun ctbl:action-update-buffer () + "Update action for the latest table model." + (interactive) + (let ((cp (ctbl:cp-get-component))) + (when cp + (ctbl:cp-update cp)))) + +(defun ctbl:action-column-header () + "Action handler on the header columns. (for normal key events)" + (interactive) + (ctbl:fire-column-header-action + (ctbl:cp-get-component) + (get-text-property (point) 'ctbl:col-id))) + +(defun ctbl:fire-column-header-action (cp col-id) + "[internal] Execute action handlers on the header columns." + (when (and cp col-id) + (loop with cmodel = (nth col-id (ctbl:model-column-model (ctbl:cp-get-model cp))) + for f in (ctbl:cmodel-click-hooks cmodel) + do (condition-case err + (funcall f cp col-id) + (error (message "Ctable: Header Click / Hook error %S [%s]" + f err)))))) + +(defun ctbl:render-column-header-keymap (col-id) + "[internal] Generate action handler on the header columns. (for header-line-format)" + (lexical-let ((col-id col-id)) + (let ((keymap (copy-keymap ctbl:column-header-keymap))) + (define-key keymap [header-line mouse-1] + (lambda () + (interactive) + (ctbl:fire-column-header-action (ctbl:cp-get-component) col-id))) + keymap))) + +(defvar ctbl:column-header-keymap + (ctbl:define-keymap + '(([mouse-1] . ctbl:action-column-header) + ("C-m" . ctbl:action-column-header) + ("RET" . ctbl:action-column-header) + )) + "Keymap for the header columns.") + +(defvar ctbl:table-mode-map + (ctbl:define-keymap + '( + ("k" . ctbl:navi-move-up) + ("j" . ctbl:navi-move-down) + ("h" . ctbl:navi-move-left) + ("l" . ctbl:navi-move-right) + + ("p" . ctbl:navi-move-up) + ("n" . ctbl:navi-move-down) + ("b" . ctbl:navi-move-left) + ("f" . ctbl:navi-move-right) + + ("e" . ctbl:navi-move-right-most) + ("a" . ctbl:navi-move-left-most) + + ("g" . ctbl:action-update-buffer) + + ([mouse-1] . ctbl:navi-on-click) + ("C-m" . ctbl:navi-on-click) + ("RET" . ctbl:navi-on-click) + + )) "Keymap for the table-mode buffer.") + +(defun ctbl:table-mode-map (&optional custom-map) + "[internal] Return a keymap object for the table buffer." + (cond + (custom-map + (set-keymap-parent custom-map ctbl:table-mode-map) + custom-map) + (t ctbl:table-mode-map))) + +(defvar ctbl:table-mode-hook nil + "This hook is called at end of setting up major mode `ctbl:table-mode'.") + +(defun ctbl:table-mode (&optional custom-map) + "Set up major mode `ctbl:table-mode'. + +\\{ctbl:table-mode-map}" + (kill-all-local-variables) + (setq truncate-lines t) + (use-local-map (ctbl:table-mode-map custom-map)) + (setq major-mode 'ctbl:table-mode + mode-name "Table Mode") + (setq buffer-undo-list t + buffer-read-only t) + (add-hook 'post-command-hook 'ctbl:start-tooltip-timer nil t) + (run-hooks 'ctbl:table-mode-hook)) + + +;; Rendering + +(defun ctbl:render-check-cell-width (rows cmodels column-widths) + "[internal] Return a list of rows. This function makes side effects: +cell widths are stored at COLUMN-WIDTHS, longer cell strings are truncated by +maximum width of the column models." + (loop for row in rows collect + (loop for c in row + for cm in cmodels + for cwmax = (ctbl:cmodel-max-width cm) + for i from 0 + for cw = (nth i column-widths) + for val = (format "%s" c) + collect + (progn + (when (and cwmax (< cwmax (string-width val))) + (setq val (truncate-string-to-width val cwmax))) + (when (< cw (string-width val)) + (setf (nth i column-widths) (string-width val))) + val)))) + +(defun ctbl:render-adjust-cell-width (cmodels column-widths total-width) + "[internal] Adjust column widths and return a list of column widths. +If TOTAL-WIDTH is nil, this function just returns COLUMN-WIDTHS. +If TOTAL-WIDTHS is shorter than sum of COLUMN-WIDTHS, this +function expands columns. The residual width is distributed over +the columns. If TOTAL-WIDTHS is longer than sum of +COLUMN-WIDTHS, this function shrinks columns to reduce the +surplus width." + (let ((init-total (loop for i in column-widths sum i))) + (cond + ((or (null total-width) + (= total-width init-total)) column-widths) + ((< total-width init-total) + (ctbl:render-adjust-cell-width-shrink + cmodels column-widths total-width init-total)) + (t + (ctbl:render-adjust-cell-width-expand + cmodels column-widths total-width init-total))))) + +(defun ctbl:render-adjust-cell-width-shrink (cmodels column-widths total-width init-total ) + "[internal] shrink column widths." + (let* ((column-widths (copy-sequence column-widths)) + (column-indexes (loop for i from 0 below (length cmodels) collect i)) + (residual (- init-total total-width))) + (loop for cnum = (length column-indexes) + until (or (= 0 cnum) (= 0 residual)) + do + (loop with ave-shrink = (max 1 (/ residual cnum)) + for idx in column-indexes + for cmodel = (nth idx cmodels) + for cwidth = (nth idx column-widths) + for min-width = (or (ctbl:cmodel-min-width cmodel) 1) + do + (cond + ((<= residual 0) (return)) ; complete + ((<= cwidth min-width) ; reject + (setq column-indexes (delete idx column-indexes))) + (t ; reduce + (let ((next-width (max 1 (- cwidth ave-shrink)))) + (incf residual (- next-width cwidth)) + (setf (nth idx column-widths) next-width)))))) + column-widths)) + +(defun ctbl:render-adjust-cell-width-expand (cmodels column-widths total-width init-total ) + "[internal] expand column widths." + (let* ((column-widths (copy-sequence column-widths)) + (column-indexes (loop for i from 0 below (length cmodels) collect i)) + (residual (- total-width init-total))) + (loop for cnum = (length column-indexes) + until (or (= 0 cnum) (= 0 residual)) + do + (loop with ave-expand = (max 1 (/ residual cnum)) + for idx in column-indexes + for cmodel = (nth idx cmodels) + for cwidth = (nth idx column-widths) + for max-width = (or (ctbl:cmodel-max-width cmodel) total-width) + do + (cond + ((<= residual 0) (return)) ; complete + ((<= max-width cwidth) ; reject + (setq column-indexes (delete idx column-indexes))) + (t ; expand + (let ((next-width (min max-width (+ cwidth ave-expand)))) + (incf residual (- cwidth next-width)) + (setf (nth idx column-widths) next-width)))))) + column-widths)) + +(defun ctbl:render-get-formats (cmodels column-widths) + "[internal] Return a list of the format functions." + (loop for cw in column-widths + for cm in cmodels + for al = (ctbl:cmodel-align cm) + collect + (lexical-let ((cw cw)) + (cond + ((eq al 'left) + (lambda (s) (ctbl:format-left cw s))) + ((eq al 'center) + (lambda (s) (ctbl:format-center cw s))) + (t + (lambda (s) (ctbl:format-right cw s))))))) + +(defun ctbl:render-choose-color (model param index) + "[internal] Choose rendering color." + (cond + ((null param) nil) + ((stringp param) param) + ((functionp param) + (funcall param model index)) + (t (let ((val (or (assq index param) + (assq t param)))) + (if val (cdr val) nil))))) + +(defun ctbl:render-bg-color (str row-id col-id model param) + "[internal] Return nil or the color string at the cell (row-id . cell-id)." + (let ((bgc-param (ctbl:param-bg-colors param))) + (cond + ((null bgc-param) nil) + ((functionp bgc-param) + (funcall bgc-param model row-id col-id str)) + (t + (let ((pair (or (assoc (cons row-id col-id) bgc-param) + (assoc t bgc-param)))) + (if pair (cdr pair) nil)))))) + +(defun ctbl:render-bg-color-put (str row-id col-id model param) + "[internal] Return the string with the background face." + (let ((bgcolor (ctbl:render-bg-color str row-id col-id model param))) + (if bgcolor + (let ((org-face (get-text-property 0 'face str))) + (propertize + (copy-sequence str) + 'face (if org-face + (append org-face (list ':background bgcolor)) + (list ':background bgcolor)))) + str))) + +(defun ctbl:render-line-color (str model param index) + "[internal] Return the propertize string." + (propertize (copy-sequence str) + 'face (list + ':foreground + (ctbl:render-choose-color model param index)))) + +(defun ctbl:render-vline-color (str model param index) + "[internal] Return the propertize string for vertical lines." + (ctbl:render-line-color str model (ctbl:param-vline-colors param) index)) + +(defun ctbl:render-hline-color (str model param index) + "[internal] Return the propertize string for horizontal lines." + (ctbl:render-line-color str model (ctbl:param-hline-colors param) index)) + +(defun ctbl:render-draw-vline-p (model param index) + "[internal] If a vertical line is needed at the column index, return t." + (cond + ((null param) nil) + ((eq 'all param) t) + ((functionp param) (funcall param model index)) + (t (and (consp param) (memq index param))))) + +(defun ctbl:render-draw-hline-p (model param index) + "[internal] If a horizontal line is needed at the row index, return t." + (cond + ((null param) nil) + ((eq 'all param) t) + ((functionp param) (funcall param model index)) + (t (memq index param)))) + +(defun ctbl:render-make-hline (column-widths model param index) + "[internal] " + (let ((vparam (ctbl:param-draw-vlines param)) + (hline (ctbl:param-horizontal-line param)) + left joint right) + (if (not (ctbl:render-draw-hline-p + model (ctbl:param-draw-hlines param) index)) + "" + (cond + ((eq 0 index) + (setq left (char-to-string (ctbl:param-left-top-corner param)) + joint (char-to-string (ctbl:param-top-junction param)) + right (char-to-string (ctbl:param-right-top-corner param)))) + ((eq -1 index) + (setq left (char-to-string (ctbl:param-left-bottom-corner param)) + joint (char-to-string (ctbl:param-bottom-junction param)) + right (char-to-string (ctbl:param-right-bottom-corner param)))) + (t + (setq left (char-to-string (ctbl:param-left-junction param)) + joint (char-to-string (ctbl:param-cross-junction param)) + right (char-to-string (ctbl:param-right-junction param))))) + (ctbl:render-hline-color + (concat + (if (ctbl:render-draw-vline-p model vparam 0) left) + (loop with ret = nil with endi = (length column-widths) + for cw in column-widths + for ci from 1 + for endp = (equal ci endi) + do + (push (make-string cw hline) ret) + (when (and (ctbl:render-draw-vline-p model vparam ci) + (not endp)) + (push joint ret)) + finally return (apply 'concat (reverse ret))) + (if (ctbl:render-draw-vline-p model vparam -1) right) + "\n") + model param index)))) + +(defun ctbl:render-join-columns (columns model param) + "[internal] Join a list of column strings with vertical lines." + (let (ret (V (char-to-string (ctbl:param-vertical-line param)))) + ;; left border line + (setq ret (if (ctbl:render-draw-vline-p + model (ctbl:param-draw-vlines param) 0) + (list (ctbl:render-vline-color V model param 0)) + nil)) + ;; content line + (loop with param-vl = (ctbl:param-draw-vlines param) + with param-vc = (ctbl:param-vline-colors param) + with endi = (length columns) + for i from 1 for endp = (equal i endi) + for cv in columns + for color = (ctbl:render-choose-color model param-vc i) + do + (push cv ret) + (when (and (ctbl:render-draw-vline-p + model (ctbl:param-draw-vlines param) i) + (not endp)) + (push (ctbl:render-vline-color V model param i) ret))) + ;; right border line + (when (ctbl:render-draw-vline-p + model (ctbl:param-draw-vlines param) -1) + (push (ctbl:render-vline-color V model param -1) ret)) + ;; join them + (mapconcat 'identity (reverse ret) ""))) + +(defun ctbl:render-sum-vline-widths (cmodels model param) + "[internal] Return a sum of the widths of vertical lines." + (let ((sum 0)) + ;; left border line + (when (ctbl:render-draw-vline-p model (ctbl:param-draw-vlines param) 0) + (incf sum)) + ;; content line + (loop with param-vl = (ctbl:param-draw-vlines param) + with endi = (length cmodels) + for i from 1 upto (length cmodels) + for endp = (equal i endi) do + (when (and (ctbl:render-draw-vline-p + model (ctbl:param-draw-vlines param) i) + (not endp)) + (incf sum))) + ;; right border line + (when (ctbl:render-draw-vline-p + model (ctbl:param-draw-vlines param) -1) + (incf sum)) + sum)) + +(defun ctbl:state-new (max-height data) + "[internal] Create output state object. see `ctbl:render-insert' function." + ;; (current-line max-height data) + (list 0 max-height data)) + +(defun ctbl:state-current (state) + "[internal] Return the current line number." + (car state)) + +(defun ctbl:state-max (state) + "[internal] Return the maximum line number or nil." + (cadr state)) + +(defun ctbl:state-increment (state) + "[internal] Increment the current line number." + (incf (car state))) + +(defun ctbl:state-set-current-data (state data) + "[internal] Set DATA at the data slot of STATE." + (setf (nth 2 state) data)) + +(defun ctbl:state-get-current-data (state) + "[internal] Return an object in the data slot of STATE." + (nth 2 state)) + +(defun ctbl:state-over-p (state) + "[internal] Return t if the current line number is over the +maximum line number." + (and (ctbl:state-max state) + (<= (ctbl:state-max state) (ctbl:state-current state)))) + +(defvar ctbl:continue-button-keymap + (ctbl:define-keymap + '(([mouse-1] . ctbl:action-continue-clicked) + ("C-m" . ctbl:action-continue-clicked) + ("RET" . ctbl:action-continue-clicked) + )) + "Keymap for the continue button.") + +(defun ctbl:render-insert (state &rest args) + "[internal] Insert ARGS into the current buffer. +If the current line number is over the limit, this function +throws `ctbl:insert-break' symbol to break loop." + (let ((str (apply 'concat args))) + (unless (or (null args) (equal "" str)) + (insert str) + (ctbl:state-increment state) + (when (ctbl:state-over-p state) + (let* ((msg (format "[Continue... (%s)]" ; data => remain row number + (ctbl:state-get-current-data state))) + (nextbar (ctbl:format-center ; -1 => chop EOL + (1- (length str)) msg))) + (insert (propertize nextbar + 'keymap ctbl:continue-button-keymap + 'face 'ctbl:face-continue-bar + 'mouse-face 'highlight) "\n")) + (throw 'ctbl:insert-break nil))))) +(put 'ctbl:render-insert 'lisp-indent-function 1) + +(defun ctbl:action-continue-clicked () + "Action for clicking the continue button." + (interactive) + (let ((cp (ctbl:cp-get-component))) + (when cp + (let ((dest (ctbl:component-dest cp))) + (setf (ctbl:dest-height dest) nil) + (ctbl:cp-update cp))))) + +(defun ctbl:dest-width-get (dest) + "[internal] Return the column number to draw the table view. +Return nil, if the width is not given. Then, the renderer draws freely." + (let ((dwidth (ctbl:dest-width dest)) ; dwidth must not be nil + (dwin (get-buffer-window))) + (cond + ((numberp dwidth) dwidth) + ((eq 'full dwidth) (window-width dwin)) + (t nil)))) + +(defun ctbl:dest-height-get (dest) + "[internal] Return the row number to draw the table view. +Return nil, if the height is not given. Then, the renderer draws freely." + (let ((dheight (ctbl:dest-height dest)) ; dheight must not be nil + (dwin (get-buffer-window))) + (cond + ((numberp dheight) dheight) + ((eq 'full dheight) (1- (window-height dwin))) + (t nil)))) + +(defun ctbl:render-main (dest model param) + "[internal] Rendering the table view. +This function assumes that the current buffer is the destination buffer." + (let* ((EOL "\n") drows + (cmodels (ctbl:model-column-model model)) + (rows (ctbl:sort + (copy-sequence (ctbl:model-data model)) cmodels + (ctbl:model-sort-state model))) + (dstate (ctbl:state-new (ctbl:dest-height-get dest) rows)) + (column-widths + (loop for c in cmodels + for title = (ctbl:cmodel-title c) + collect (max (or (ctbl:cmodel-min-width c) 0) + (or (and title (length title)) 0)))) + column-format) + ;; check cell widths + (setq drows (ctbl:render-check-cell-width rows cmodels column-widths)) + ;; adjust cell widths for ctbl:dest width + (when (ctbl:dest-width-get dest) + (setq column-widths + (ctbl:render-adjust-cell-width + cmodels column-widths + (- (ctbl:dest-width-get dest) + (ctbl:render-sum-vline-widths + cmodels model param))))) + (setq column-format (ctbl:render-get-formats cmodels column-widths)) + (catch 'ctbl:insert-break + (ctbl:render-main-header dest model param + cmodels dstate column-widths) + (ctbl:render-main-content dest model param + cmodels drows dstate column-widths column-format)) + ;; return the sorted list + rows)) + +(defun ctbl:render-main-header (dest model param cmodels dstate column-widths) + "[internal] Render the table header." + (let ((EOL "\n") + (header-string + (ctbl:render-join-columns + (loop for cm in cmodels + for i from 0 + for cw in column-widths + collect + (propertize + (ctbl:format-center cw (ctbl:cmodel-title cm)) + 'ctbl:col-id i + 'local-map (ctbl:render-column-header-keymap i) + 'mouse-face 'highlight)) + model param))) + (cond + ((and (eq 'buffer (ctbl:dest-type dest)) + (ctbl:param-fixed-header param)) + ;; buffer header-line + (let* ((fcol (/ (car (window-fringes)) + (frame-char-width))) + (header-text (concat (make-string fcol ? ) header-string))) + (setq header-line-format header-text) + ;; save header-text for hscroll updating + (set (make-local-variable 'ctbl:header-text) header-text))) + (t + ;; content area + (ctbl:render-insert dstate ; border line + (ctbl:render-make-hline column-widths model param 0)) + (ctbl:render-insert dstate header-string EOL) ; header columns + )))) + +(defun ctbl:render-main-content (dest model param cmodels rows + dstate column-widths column-format) + "[internal] Render the table content." + (let ((EOL "\n") (row-num (length rows))) + (loop for cols in rows + for row-index from 0 + do + (ctbl:render-insert dstate + (ctbl:render-make-hline + column-widths model param (1+ row-index))) + (ctbl:render-insert dstate + (ctbl:render-join-columns + (loop for i in cols + for s = (if (stringp i) i (format "%s" i)) + for fmt in column-format + for cw in column-widths + for col-index from 0 + for str = (ctbl:render-bg-color-put + (funcall fmt i) row-index col-index + model param) + collect + (propertize str + 'ctbl:cell-id (cons row-index col-index) + 'ctbl:cell-width cw)) + model param) EOL) + (ctbl:state-set-current-data dstate (- row-num row-index))) + ;; bottom border line + (ctbl:render-insert dstate + (ctbl:render-make-hline column-widths model param -1)))) + +(defun ctbl:pop-tooltip (string) + "[internal] Show STRING in tooltip." + (cond + ((and (memq 'pos-tip ctbl:tooltip-method) window-system (featurep 'pos-tip)) + (pos-tip-show (ctbl:string-fill-paragraph string) + 'popup-tip-face nil nil 0)) + ((and (memq 'popup ctbl:tooltip-method) (featurep 'popup)) + (popup-tip string)) + ((memq 'minibuffer ctbl:tooltip-method) + (let ((message-log-max nil)) + (message string))))) + +(defun ctbl:show-cell-in-tooltip (&optional unless-visible) + "Show cell at point in tooltip. +When UNLESS-VISIBLE is non-nil, show tooltip only when data in +cell is truncated." + (interactive) + (let* ((cp (ctbl:cp-get-component)) + (data (when cp (ctbl:cp-get-selected-data-cell cp)))) + (when data + (let ((string (if (stringp data) data (format "%S" data))) + (width (get-text-property (point) 'ctbl:cell-width))) + (when (or (not unless-visible) + (and (integerp width) (>= (length string) width))) + (ctbl:pop-tooltip string)))))) + +(defvar ctbl:tooltip-delay 1) + +(defvar ctbl:tooltip-timer nil) + +(defun ctbl:start-tooltip-timer () + (unless ctbl:tooltip-timer + (setq ctbl:tooltip-timer + (run-with-idle-timer ctbl:tooltip-delay nil + (lambda () + (ctbl:show-cell-in-tooltip t) + (setq ctbl:tooltip-timer nil)))))) + + +;; Rendering utilities + +(defun ctbl:format-truncate (org limit-width &optional ellipsis) + "[internal] Truncate a string ORG with LIMIT-WIDTH, like `truncate-string-to-width'." + (setq org (replace-regexp-in-string "\n" " " org)) + (if (< limit-width (string-width org)) + (let ((str (truncate-string-to-width + (substring org 0) limit-width 0 nil ellipsis))) + (when (< limit-width (string-width str)) + (setq str (truncate-string-to-width (substring org 0) + limit-width))) + (propertize str 'mouse-face 'highlight) + (unless (get-text-property 0 'help-echo str) + (propertize str 'help-echo org)) + str) + org)) + +(defun ctbl:format-right (width string &optional padding) + "[internal] Format STRING, padding on the left with the character PADDING." + (let* ((padding (or padding ?\ )) + (cnt (or (and string + (ctbl:format-truncate string width t)) + "")) + (len (string-width cnt)) + (margin (max 0 (- width len)))) + (concat (make-string margin padding) cnt))) + +(defun ctbl:format-center (width string &optional padding) + "[internal] Format STRING in the center, padding on the both +sides with the character PADDING." + (let* ((padding (or padding ?\ )) + (cnt (or (and string + (ctbl:format-truncate string width t)) + "")) + (len (string-width cnt)) + (margin (max 0 (/ (- width len) 2)))) + (concat + (make-string margin padding) cnt + (make-string (max 0 (- width len margin)) padding)))) + +(defun ctbl:format-left (width string &optional padding) + "[internal] Format STRING, padding on the right with the character PADDING." + (let* ((padding (or padding ?\ )) + (cnt (or (and string + (ctbl:format-truncate string width t)) + "")) + (len (string-width cnt)) + (margin (max 0 (- width len)))) + (concat cnt (make-string margin padding)))) + +(defun ctbl:sort-string-lessp (i j) + "[internal] String comparator." + (cond + ((string= i j) 0) + ((string< i j) -1) + (t 1))) + +(defun ctbl:sort-number-lessp (i j) + "[internal] Number comparator." + (cond + ((= i j) 0) + ((< i j) -1) + (t 1))) + +(defun ctbl:sort (rows cmodels orders) + "[internal] Sort rows according to order indexes and column models." + (let* + ((comparator + (lambda (ref) + (lexical-let + ((ref ref) + (f (or (ctbl:cmodel-sorter (nth ref cmodels)) + 'ctbl:sort-string-lessp))) + (lambda (i j) + (funcall f (nth ref i) (nth ref j)))))) + (negative-comparator + (lambda (ref) + (lexical-let ((cp (funcall comparator ref))) + (lambda (i j) (- (funcall cp i j)))))) + (to-bool + (lambda (f) + (lexical-let ((f f)) + (lambda (i j) + (< (funcall f i j) 0))))) + (chain + (lambda (fs) + (lexical-let ((fs fs)) + (lambda (i j) + (loop for f in fs + for v = (funcall f i j) + unless (eq 0 v) + return v + finally return 0)))))) + (sort rows + (loop with fs = nil + for o in (reverse (copy-sequence orders)) + for gen = (if (< 0 o) comparator negative-comparator) + for f = (funcall gen (1- (abs o))) + do (push f fs) + finally return (funcall to-bool (funcall chain fs)))))) + +(defun ctbl:string-fill-paragraph (string &optional justify) + "[internal] `fill-paragraph' against STRING." + (with-temp-buffer + (erase-buffer) + (insert string) + (goto-char (point-min)) + (fill-paragraph justify) + (buffer-string))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; CTable API + +;; buffer + +(defun* ctbl:open-table-buffer(&key buffer width height custom-map model param) + "Open a table buffer simply. +This function uses the function +`ctbl:create-table-component-buffer' internally." + (let ((cp (ctbl:create-table-component-buffer + :buffer buffer :width width :height height + :custom-map custom-map :model model :param param))) + (switch-to-buffer (ctbl:cp-get-buffer cp)))) + +(defun* ctbl:create-table-component-buffer(&key buffer width height custom-map model param) + "Return a table buffer with some customize parameters. + +This function binds the component object at the +buffer local variable `ctbl:component'. + +The size of table is calculated from the window that shows BUFFER or the selected window. +BUFFER is the buffer to be rendered. If BUFFER is nil, this function creates a new buffer. +CUSTOM-MAP is the additional keymap that is added to default keymap `ctbl:table-mode-map'." + (let* ((dest (ctbl:dest-init-buffer buffer width height custom-map)) + (cp (ctbl:cp-new dest model param))) + (setf (ctbl:dest-after-update-func dest) + (lambda () + (ctbl:dest-buffer-update-header))) + (with-current-buffer (ctbl:dest-buffer dest) + (set (make-local-variable 'ctbl:component) cp)) + cp)) + +(defun ctbl:dest-buffer-update-header () + "[internal] After auto hscrolling, update the horizontal position of the header line." + (run-at-time 0.01 nil 'ctbl:dest-buffer-update-header--deferred)) + +(defun ctbl:dest-buffer-update-header--deferred () + "[internal] Adjust header line position." + (when (boundp 'ctbl:header-text) + (let* ((left (window-hscroll)) + (text (substring ctbl:header-text left))) + (setq header-line-format text)) + (force-window-update (current-buffer)))) + + +(defun ctbl:popup-table-buffer-easy (rows &optional header-row) + "Popup a table buffer from a list of rows." + (pop-to-buffer (ctbl:create-table-buffer-easy rows header-row))) + +(defun ctbl:open-table-buffer-easy (rows &optional header-row) + "Open a table buffer from a list of rows." + (switch-to-buffer (ctbl:create-table-buffer-easy rows header-row))) + +(defun ctbl:create-table-buffer-easy (rows &optional header-row) + "Return a table buffer from a list of rows." + (let* ((col-num (or (and header-row (length header-row)) + (and (car rows) (length (car rows))))) + (column-models + (if header-row + (loop for i in header-row + collect (make-ctbl:cmodel :title (format "%s" i) :min-width 5)) + (loop for i from 0 below col-num + for ch = (char-to-string (+ ?A i)) + collect (make-ctbl:cmodel :title ch :min-width 5)))) + (model + (make-ctbl:model + :column-model column-models :data rows)) + (cp (ctbl:create-table-component-buffer + :model model))) + (ctbl:cp-get-buffer cp))) + +;; region + +(defun* ctbl:create-table-component-region(&key width height keymap model param) + "Insert markers of the rendering destination at current point and display the table view. + +This function returns a component object and stores it at the text property `ctbl:component'. + +WIDTH and HEIGHT are reference size of the table view. If those are nil, the size is calculated from the selected window. +KEYMAP is the keymap that is put to the text property `keymap'. If KEYMAP is nil, `ctbl:table-mode-map' is used." + (let (mark-begin mark-end) + (setq mark-begin (point-marker)) + (insert " ") + (setq mark-end (point-marker)) + (save-excursion + (let* ((dest (ctbl:dest-init-region (current-buffer) mark-begin mark-end width height)) + (cp (ctbl:cp-new dest model param)) + (after-update-func + (lexical-let ((keymap keymap) (cp cp)) + (lambda () + (ctbl:dest-with-region (ctbl:component-dest cp) + (let (buffer-read-only) + (put-text-property (point-min) (1- (point-max)) + 'ctbl:component cp) + (ctbl:fill-keymap-property + (point-min) (1- (point-max)) + (or keymap ctbl:table-mode-map)))))))) + (setf (ctbl:dest-after-update-func dest) after-update-func) + (funcall after-update-func) + cp)))) + + +;; inline + +(defun* ctbl:get-table-text(&key width height model param) + "Return a text that is drew the table view. + +In this case, the rendering destination object is disposable. So, +one can not modify the obtained text with `ctbl:xxx' functions. + +WIDTH and HEIGHT are reference size of the table view." + (let* ((dest (ctbl:dest-init-inline width height)) + (cp (ctbl:cp-new dest model param)) + text) + (setq text + (with-current-buffer (ctbl:cp-get-buffer cp) + (buffer-substring (point-min) (point-max)))) + (kill-buffer (ctbl:cp-get-buffer cp)) + text)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Demo + +(defun ctbl:demo () + "Sample code for implementation for the table model." + (interactive) + (let ((param (copy-ctbl:param ctbl:default-rendering-param))) + ;; rendering parameters + (setf (ctbl:param-fixed-header param) t) + (setf (ctbl:param-hline-colors param) + '((0 . "#00000") (1 . "#909090") (-1 . "#ff0000") (t . "#00ff00"))) + (setf (ctbl:param-draw-hlines param) + (lambda (model row-index) + (cond ((memq row-index '(0 1 -1)) t) + (t (= 0 (% (1- row-index) 5)))))) + (setf (ctbl:param-bg-colors param) + (lambda (model row-id col-id str) + (cond ((string-match "CoCo" str) "LightPink") + ((= 0 (% (1- row-index) 2)) "Darkseagreen1") + (t nil)))) + (let ((cp + (ctbl:create-table-component-buffer + :width nil :height nil + :model + (make-ctbl:model + :column-model + (list (make-ctbl:cmodel + :title "A" :sorter 'ctbl:sort-number-lessp + :min-width 5 :align 'right) + (make-ctbl:cmodel + :title "Title" :align 'center + :sorter (lambda (a b) (ctbl:sort-number-lessp (length a) (length b)))) + (make-ctbl:cmodel + :title "Comment" :align 'left)) + :data + '((1 "Bon Tanaka" "8 Year Curry." 'a) + (2 "Bon Tanaka" "Nan-ban Curry." 'b) + (3 "Bon Tanaka" "Half Curry." 'c) + (4 "Bon Tanaka" "Katsu Curry." 'd) + (5 "Bon Tanaka" "Gyu-don." 'e) + (6 "CoCo Ichi" "Beaf Curry." 'f) + (7 "CoCo Ichi" "Poke Curry." 'g) + (8 "CoCo Ichi" "Yasai Curry." 'h) + (9 "Berkley" "Hamburger Curry." 'i) + (10 "Berkley" "Lunch set." 'j) + (11 "Berkley" "Coffee." k)) + :sort-state + '(2 1) + ) + :param param))) + (ctbl:cp-add-click-hook + cp (lambda () (message "CTable : Click Hook [%S]" + (ctbl:cp-get-selected-data-row cp)))) + (ctbl:cp-add-selection-change-hook cp (lambda () (message "CTable : Select Hook"))) + (ctbl:cp-add-update-hook cp (lambda () (message "CTable : Update Hook"))) + (switch-to-buffer (ctbl:cp-get-buffer cp))))) + +;; (progn (eval-current-buffer) (ctbl:demo)) + +(provide 'ctable) +;;; ctable.el ends here diff --git a/conf/emacs.d/deferred.el b/conf/emacs.d/deferred.el new file mode 100644 index 0000000..fe3b0ca --- /dev/null +++ b/conf/emacs.d/deferred.el @@ -0,0 +1,952 @@ +;;; deferred.el --- Simple asynchronous functions for emacs lisp + +;; Copyright (C) 2010, 2011, 2012 SAKURAI Masashi + +;; Author: SAKURAI Masashi +;; Version: 0.3.1 +;; Keywords: deferred, async +;; URL: https://github.com/kiwanami/emacs-deferred + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; 'deferred.el' is a simple library for asynchronous tasks. +;; [https://github.com/kiwanami/emacs-deferred] + +;; The API is almost the same as JSDeferred written by cho45. See the +;; JSDeferred and Mochikit.Async web sites for further documentations. +;; [https://github.com/cho45/jsdeferred] +;; [http://mochikit.com/doc/html/MochiKit/Async.html] + +;; A good introduction document (JavaScript) +;; [http://cho45.stfuawsc.com/jsdeferred/doc/intro.en.html] + +;;; Samples: + +;; ** HTTP Access + +;; (require 'url) +;; (deferred:$ +;; (deferred:url-retrieve "http://www.gnu.org") +;; (deferred:nextc it +;; (lambda (buf) +;; (insert (with-current-buffer buf (buffer-string))) +;; (kill-buffer buf)))) + +;; ** Invoking command tasks + +;; (deferred:$ +;; (deferred:process "wget" "-O" "a.jpg" "http://www.gnu.org/software/emacs/tour/images/splash.png") +;; (deferred:nextc it +;; (lambda (x) (deferred:process "convert" "a.jpg" "-resize" "100x100" "jpg:b.jpg"))) +;; (deferred:nextc it +;; (lambda (x) +;; (insert-image (create-image (expand-file-name "b.jpg") 'jpeg nil))))) + +;; See the readme for further API documentation. + +;; ** Applications + +;; *Inertial scrolling for Emacs +;; [https://github.com/kiwanami/emacs-inertial-scroll] + +;; This program makes simple multi-thread function, using +;; deferred.el. + +(eval-when-compile + (require 'cl)) + +(defvar deferred:version nil "deferred.el version") +(setq deferred:version "0.3") + +;;; 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 (symbolp form &rest form))) + `(cond + ((null deferred:debug-on-signal) + (condition-case ,var ,protected-form ,@handlers)) + (t + (let ((deferred:debug-on-signal-backup debug-on-signal)) + (setq debug-on-signal deferred:debug-on-signal) + (unwind-protect + (condition-case ,var ,protected-form ,@handlers) + (setq debug-on-signal deferred:debug-on-signal-backup)))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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:esc-msg (msg) + "[internal] Escaping the character '%'." + (replace-regexp-in-string + "\\([^%]\\|^\\)%\\([^%]\\)" "\\1%%\\2" msg)) + +(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 (error-msg) + "[internal] Default errorback function." + (error (deferred:esc-msg + (cond + ((stringp error-msg) error-msg) + ((listp error-msg) (cadr error-msg)) + (t (format "%S" error-msg)))))) + +(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)))) + (cond + (callback + (let (value (next-deferred (deferred-next d))) + (deferred:condition-case err + (progn + (setq 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 (error-message-string 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) (error-message-string err)) + (deferred:esc-msg (error-message-string err)))))))) + (t ; <= (null callback) + (let ((next-deferred (deferred-next d))) + (cond + (next-deferred + (deferred:exec-task next-deferred which arg)) + ((eq which 'ok) arg) + (t (error (deferred:esc-msg 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 'ok 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)) (error 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" ) + (lexical-let ((nd (deferred:new)) + (len (length alst)) + values) + (loop for pair in + (deferred:parallel-func-to-deferred alst) + with cd ; current child deferred + do + (lexical-let ((name (car pair))) + (setq cd + (deferred:nextc (cdr pair) + (lambda (x) + (push (cons name x) values) + (deferred:message "PARALLEL VALUE [%s/%s] %s" + (length values) len (cons name x)) + (when (= len (length values)) + (deferred:message "PARALLEL COLLECTED") + (deferred:post-task nd 'ok (nreverse values))) + nil))) + (deferred:error cd + (lambda (e) + (push (cons name e) values) + (deferred:message "PARALLEL ERROR [%s/%s] %s" + (length values) len (cons name e)) + (when (= (length values) len) + (deferred:message "PARALLEL COLLECTED") + (deferred:post-task nd 'ok (nreverse values))) + nil)))) + nd)) + +(defun deferred:parallel-list (lst) + "[internal] Deferred list implementation for `deferred:parallel'. " + (deferred:message "PARALLEL" ) + (lexical-let* + ((pd (deferred:parallel-main (deferred:parallel-array-to-alist lst))) + (rd (deferred:nextc pd 'deferred:parallel-alist-to-array))) + (setf (deferred-cancel rd) + (lambda (x) (deferred:default-cancel x) + (deferred:cancel pd))) + rd)) + +(defun deferred:parallel (&rest args) + "Return a deferred object that calls given deferred objects or +functions in parallel and wait for all callbacks. The following +deferred task will be called with an array of the return +values. ARGS can be a list or an alist of deferred objects or +functions." + (deferred:message "PARALLEL : %s" args) + (deferred:trans-multi-args args + 'deferred:parallel 'deferred:parallel-list 'deferred:parallel-main)) + +(defun deferred:earlier-main (alst) + "[internal] Deferred alist implementation for `deferred:earlier'. " + (deferred:message "EARLIER" ) + (lexical-let ((nd (deferred:new)) + (len (length alst)) + value results) + (loop for pair in + (deferred:parallel-func-to-deferred alst) + with cd ; current child deferred + do + (lexical-let ((name (car pair))) + (setq cd + (deferred:nextc (cdr pair) + (lambda (x) + (push (cons name x) results) + (cond + ((null value) + (setq value (cons name x)) + (deferred:message "EARLIER VALUE %s" (cons name value)) + (deferred:post-task nd 'ok value)) + (t + (deferred:message "EARLIER MISS [%s/%s] %s" (length results) len (cons name value)) + (when (eql (length results) len) + (deferred:message "EARLIER COLLECTED")))) + nil))) + (deferred:error cd + (lambda (e) + (push (cons name e) results) + (deferred:message "EARLIER ERROR [%s/%s] %s" (length results) len (cons name e)) + (when (and (eql (length results) len) (null value)) + (deferred:message "EARLIER FAILED") + (deferred:post-task nd 'ok nil)) + nil)))) + nd)) + +(defun deferred:earlier-list (lst) + "[internal] Deferred list implementation for `deferred:earlier'. " + (deferred:message "EARLIER" ) + (lexical-let* + ((pd (deferred:earlier-main (deferred:parallel-array-to-alist lst))) + (rd (deferred:nextc pd (lambda (x) (cdr x))))) + (setf (deferred-cancel rd) + (lambda (x) (deferred:default-cancel x) + (deferred:cancel pd))) + rd)) + + +(defun deferred:earlier (&rest args) + "Return a deferred object that calls given deferred objects or +functions in parallel and wait for the first callback. The +following deferred task will be called with the first return +value. ARGS can be a list or an alist of deferred objects or +functions." + (deferred:message "EARLIER : %s" args) + (deferred:trans-multi-args args + 'deferred:earlier 'deferred:earlier-list 'deferred:earlier-main)) + +(defmacro deferred:timeout (timeout-msec timeout-form d) + "Time out macro on a deferred task D. If the deferred task D +does not complete within TIMEOUT-MSEC, this macro cancels the +deferred task and return the TIMEOUT-FORM." + `(deferred:earlier + (deferred:nextc (deferred:wait ,timeout-msec) + (lambda (x) ,timeout-form)) + ,d)) + +(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) + (deferred:buffer-string + (format "Process [%s] exited abnormally : %%s" + command) proc-buf) + (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 (error-message-string 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 diff --git a/conf/emacs.d/epc.el b/conf/emacs.d/epc.el new file mode 100644 index 0000000..33a4248 --- /dev/null +++ b/conf/emacs.d/epc.el @@ -0,0 +1,911 @@ +;;; epc.el --- A RPC stack for the Emacs Lisp + +;; Copyright (C) 2011, 2012 Masashi Sakurai + +;; Author: SAKURAI Masashi +;; Version: 0.1.1 +;; Keywords: lisp, rpc +;; Package-Requires: ((concurrent "0.3.1") (ctable "0.1.1")) +;; URL: https://github.com/kiwanami/emacs-epc + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; This program is an asynchronous RPC stack for Emacs. Using this +;; RPC stack, the Emacs can communicate with the peer process. +;; Because the protocol is S-expression encoding and consists of +;; asynchronous communications, the RPC response is fairly good. +;; +;; Current implementations for the EPC are followings: +;; - epcs.el : Emacs Lisp implementation +;; - RPC::EPC::Service : Perl implementation + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'concurrent) +(require 'ctable) + + +;;================================================== +;; Utility + +(defvar epc:debug-out nil) +(defvar epc:debug-buffer "*epc log*") + +;;(setq epc:debug-out t) +;;(setq epc:debug-out nil) + +(defun epc:log-init () + (when (get-buffer epc:debug-buffer) + (kill-buffer epc:debug-buffer))) + +(defun epc:log (&rest args) + (when epc:debug-out + (with-current-buffer + (get-buffer-create epc:debug-buffer) + (buffer-disable-undo) + (goto-char (point-max)) + (insert (apply 'format args) "\n")))) + +(defun epc:make-procbuf (name) + "[internal] Make a process buffer." + (let ((buf (get-buffer-create name))) + (with-current-buffer buf + (set (make-local-variable 'kill-buffer-query-functions) nil) + (erase-buffer) (buffer-disable-undo)) + buf)) + +(defun epc:document-function (function docstring) + "Document FUNCTION with DOCSTRING. Use this for `defstruct' accessor etc." + (put function 'function-documentation docstring)) +(put 'epc:document-function 'lisp-indent-function 'defun) +(put 'epc:document-function 'doc-string-elt 2) + + +;;================================================== +;; Low Level Interface + +(defvar epc:uid 1) + +(defun epc:uid () + (incf epc:uid)) + +(defvar epc:accept-process-timeout 100 "[internal] msec") + + +(defstruct epc:connection + "Set of information for network connection and event handling. + +name : Connection name. This name is used for process and buffer names. +process : Connection process object. +buffer : Working buffer for the incoming data. +channel : Event channels for incoming messages." + name process buffer channel) + +(epc:document-function 'epc:connection-name + "[internal] Connection name. This name is used for process and buffer names. + +\(fn EPC:CONNECTION)") + +(epc:document-function 'epc:connection-process + "[internal] Connection process object. + +\(fn EPC:CONNECTION)") + +(epc:document-function 'epc:connection-buffer + "[internal] Working buffer for the incoming data. + +\(fn EPC:CONNECTION)") + +(epc:document-function 'epc:connection-channel + "[internal] Event channels for incoming messages. + +\(fn EPC:CONNECTION)") + + +(defun epc:connect (host port) + "[internal] Connect the server, initialize the process and +return epc:connection object." + (epc:log ">> Connection start: %s:%s" host port) + (lexical-let* ((connection-id (epc:uid)) + (connection-name (format "epc con %s" connection-id)) + (connection-buf (epc:make-procbuf (format "*%s*" connection-name))) + (connection-process + (open-network-stream connection-name connection-buf host port)) + (channel (cc:signal-channel connection-name)) + (connection (make-epc:connection + :name connection-name + :process connection-process + :buffer connection-buf + :channel channel))) + (epc:log ">> Connection establish") + (set-process-coding-system connection-process 'binary 'binary) + (set-process-filter connection-process + (lambda (p m) + (epc:process-filter connection p m))) + (set-process-sentinel connection-process + (lambda (p e) + (epc:process-sentinel connection p e))) + (set-process-query-on-exit-flag connection-process nil) + connection)) + +(defun epc:connection-reset (connection) + "[internal] Reset the connection for restarting the process." + (cc:signal-disconnect-all (epc:connection-channel connection)) + connection) + +(defun epc:process-sentinel (connection process msg) + (epc:log "!! Process Sentinel [%s] : %S : %S" + (epc:connection-name connection) process msg) + (epc:disconnect connection)) + +(defun epc:net-send (connection sexp) + (let* ((msg (encode-coding-string + (concat (epc:prin1-to-string sexp) "\n") 'utf-8-unix)) + (string (concat (epc:net-encode-length (length msg)) msg)) + (proc (epc:connection-process connection))) + (epc:log ">> SEND : [%S]" string) + (process-send-string proc string))) + +(defun epc:disconnect (connection) + (lexical-let + ((process (epc:connection-process connection)) + (buf (epc:connection-buffer connection)) + (name (epc:connection-name connection))) + (epc:log "!! Disconnect [%s]" name) + (when process + (set-process-sentinel process nil) + (delete-process process) + (when (get-buffer buf) (kill-buffer buf))) + (epc:log "!! Disconnected finished [%s]" name))) + +(defun epc:process-filter (connection process message) + (epc:log "INCOMING: [%s] [%S]" (epc:connection-name connection) message) + (with-current-buffer (epc:connection-buffer connection) + (goto-char (point-max)) + (insert message) + (epc:process-available-input connection process))) + +(defun epc:process-available-input (connection process) + "Process all complete messages that have arrived from Lisp." + (with-current-buffer (process-buffer process) + (while (epc:net-have-input-p) + (let ((event (epc:net-read-or-lose process)) + (ok nil)) + (epc:log "<< RECV [%S]" event) + (unwind-protect + (condition-case err + (progn + (apply 'cc:signal-send + (cons (epc:connection-channel connection) event)) + (setq ok t)) + ('error (epc:log "MsgError: %S / <= %S" err event))) + (unless ok + (epc:run-when-idle 'epc:process-available-input connection process))))))) + +(defun epc:net-have-input-p () + "Return true if a complete message is available." + (goto-char (point-min)) + (and (>= (buffer-size) 6) + (>= (- (buffer-size) 6) (epc:net-decode-length)))) + +(defun epc:run-when-idle (function &rest args) + "Call FUNCTION as soon as Emacs is idle." + (apply #'run-at-time + (if (featurep 'xemacs) itimer-short-interval 0) + nil function args)) + +(defun epc:net-read-or-lose (process) + (condition-case error + (epc:net-read) + (error + (debug 'error error) + (error "net-read error: %S" error)))) + +(defun epc:net-read () + "Read a message from the network buffer." + (goto-char (point-min)) + (let* ((length (epc:net-decode-length)) + (start (+ 6 (point))) + (end (+ start length)) content) + (assert (plusp length)) + (prog1 (save-restriction + (narrow-to-region start end) + (read (decode-coding-string + (buffer-string) 'utf-8-unix))) + (delete-region (point-min) end)))) + +(defun epc:net-decode-length () + "Read a 24-bit hex-encoded integer from buffer." + (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) 16)) + +(defun epc:net-encode-length (n) + "Encode an integer into a 24-bit hex string." + (format "%06x" n)) + +(defun epc:prin1-to-string (sexp) + "Like `prin1-to-string' but don't octal-escape non-ascii characters. +This is more compatible with the CL reader." + (with-temp-buffer + (let (print-escape-nonascii + print-escape-newlines + print-length + print-level) + (prin1 sexp (current-buffer)) + (buffer-string)))) + + +;;================================================== +;; High Level Interface + +(defstruct epc:manager + "Root object that holds all information related to an EPC activity. + +`epc:start-epc' returns this object. + +title : instance name for displaying on the `epc:controller' UI +server-process : process object for the peer +commands : a list of (prog . args) +port : port number +connection : epc:connection instance +methods : alist of method (name . function) +sessions : alist of session (id . deferred) +exit-hook : functions for after shutdown EPC connection" + title server-process commands port connection methods sessions exit-hooks) + +(epc:document-function 'epc:manager-title + "Instance name (string) for displaying on the `epc:controller' UI + +You can modify this slot using `setf' to change the title column +in the `epc:controller' table UI. + +\(fn EPC:MANAGER)") + +(epc:document-function 'epc:manager-server-process + "Process object for the peer. + +This is *not* network process but the external program started by +`epc:start-epc'. For network process, see `epc:connection-process'. + +\(fn EPC:MANAGER)") + +(epc:document-function 'epc:manager-commands + "[internal] a list of (prog . args) + +\(fn EPC:MANAGER)") + +(epc:document-function 'epc:manager-port + "Port number (integer). + +\(fn EPC:MANAGER)") + +(epc:document-function 'epc:manager-connection + "[internal] epc:connection instance + +\(fn EPC:MANAGER)") + +(epc:document-function 'epc:manager-methods + "[internal] alist of method (name . function) + +\(fn EPC:MANAGER)") + +(epc:document-function 'epc:manager-sessions + "[internal] alist of session (id . deferred) + +\(fn EPC:MANAGER)") + +(epc:document-function 'epc:manager-exit-hooks + "Hooks called after shutdown EPC connection. + +Use `epc:manager-add-exit-hook' to add hook. + +\(fn EPC:MANAGER)") + +(defstruct epc:method + "Object to hold serving method information. + +name : method name (symbol) ex: 'test +task : method function (function with one argument) +arg-specs : arg-specs (one string) ex: \"(A B C D)\" +docstring : docstring (one string) ex: \"A test function. Return sum of A,B,C and D\" +" + name task docstring arg-specs) + +(epc:document-function 'epc:method-name + "[internal] method name (symbol) ex: 'test + +\(fn EPC:METHOD)") + +(epc:document-function 'epc:method-task + "[internal] method function (function with one argument) + +\(fn EPC:METHOD)") + +(epc:document-function 'epc:method-arg-specs + "[internal] arg-specs (one string) ex: \"(A B C D)\" + +\(fn EPC:METHOD)") + +(epc:document-function 'epc:method-docstring + "[internal] docstring (one string) ex: \"A test function. Return sum of A,B,C and D\" + +\(fn EPC:METHOD)") + + +(defvar epc:live-connections nil + "[internal] A list of `epc:manager' objects those currently connect to the epc peer. +This variable is for debug purpose.") + +(defun epc:live-connections-add (mngr) + "[internal] Add the EPC manager object." + (push mngr epc:live-connections)) + +(defun epc:live-connections-delete (mngr) + "[internal] Remove the EPC manager object." + (setq epc:live-connections (delete mngr epc:live-connections))) + + +(defun epc:start-epc (server-prog server-args) + "Start the epc server program and return an epc:manager object. + +Start server program SERVER-PROG with command line arguments +SERVER-ARGS. The server program must print out the port it is +using at the first line of its stdout. If the server prints out +non-numeric value in the first line or does not print out the +port number in three seconds, it is regarded as start-up +failure." + (let ((mngr (epc:start-server server-prog server-args))) + (epc:init-epc-layer mngr) + mngr)) + +(defun epc:server-process-name (uid) + (format "epc:server:%s" uid)) + +(defun epc:server-buffer-name (uid) + (format " *%s*" (epc:server-process-name uid))) + +(defun epc:start-server (server-prog server-args) + "[internal] Start a peer server and return an epc:manager instance which is set up partially." + (let* ((uid (epc:uid)) + (process-name (epc:server-process-name uid)) + (process-buffer (get-buffer-create (epc:server-buffer-name uid))) + (process (apply 'start-process + process-name process-buffer + server-prog server-args)) + (cont 1) port) + (while cont + (accept-process-output process 0 epc:accept-process-timeout t) + (let ((port-str (with-current-buffer process-buffer + (buffer-string)))) + (cond + ((string-match "^[0-9]+$" port-str) + (setq port (string-to-number port-str) + cont nil)) + ((< 0 (length port-str)) + (error "Server may raise an error. \ +Use \"M-x epc:pop-to-last-server-process-buffer RET\" \ +to see full traceback:\n%s" port-str)) + ((not (eq 'run (process-status process))) + (setq cont nil)) + (t + (incf cont) + (when (< 30 cont) ; timeout 3 seconds + (error "Timeout server response.")))))) + (set-process-query-on-exit-flag process nil) + (make-epc:manager :server-process process + :commands (cons server-prog server-args) + :title (mapconcat 'identity (cons server-prog server-args) " ") + :port port + :connection (epc:connect "localhost" port)))) + +(defun epc:stop-epc (mngr) + "Disconnect the connection for the server." + (let* ((proc (epc:manager-server-process mngr)) + (buf (and proc (process-buffer proc)))) + (epc:disconnect (epc:manager-connection mngr)) + (when proc + (accept-process-output proc 0 epc:accept-process-timeout t)) + (when (and proc (equal 'run (process-status proc))) + (kill-process proc)) + (when buf (kill-buffer buf)) + (condition-case err + (epc:manager-fire-exit-hook mngr) + (error (epc:log "Error on exit-hooks : %S / " err mngr))) + (epc:live-connections-delete mngr))) + +(defun epc:start-epc-debug (port) + "[internal] Return an epc:manager instance which is set up partially." + (epc:init-epc-layer + (make-epc:manager :server-process nil + :commands (cons "[DEBUG]" nil) + :port port + :connection (epc:connect "localhost" port)))) + +(defun epc:args (args) + "[internal] If ARGS is an atom, return it. If list, return the cadr of it." + (cond + ((atom args) args) + (t (cadr args)))) + +(defun epc:init-epc-layer (mngr) + "[internal] Connect to the server program and return an epc:connection instance." + (lexical-let* + ((mngr mngr) + (conn (epc:manager-connection mngr)) + (channel (epc:connection-channel conn))) + ;; dispatch incoming messages with the lexical scope + (loop for (method . body) in + `((call + . (lambda (args) + (epc:log "SIG CALL: %S" args) + (apply 'epc:handler-called-method ,mngr (epc:args args)))) + (return + . (lambda (args) + (epc:log "SIG RET: %S" args) + (apply 'epc:handler-return ,mngr (epc:args args)))) + (return-error + . (lambda (args) + (epc:log "SIG RET-ERROR: %S" args) + (apply 'epc:handler-return-error ,mngr (epc:args args)))) + (epc-error + . (lambda (args) + (epc:log "SIG EPC-ERROR: %S" args) + (apply 'epc:handler-epc-error ,mngr (epc:args args)))) + (methods + . (lambda (args) + (epc:log "SIG METHODS: %S" args) + (epc:handler-methods ,mngr (caadr args)))) + ) do + (cc:signal-connect channel method body)) + (epc:live-connections-add mngr) + mngr)) + + + +(defun epc:manager-add-exit-hook (mngr hook-function) + "Register the HOOK-FUNCTION which is called after the EPC connection closed by the EPC controller UI. +HOOK-FUNCTION is a function with no argument." + (let* ((hooks (epc:manager-exit-hooks mngr))) + (setf (epc:manager-exit-hooks mngr) (cons hook-function hooks)) + mngr)) + +(defun epc:manager-fire-exit-hook (mngr) + "[internal] Call exit-hooks functions of MNGR. After calling hooks, this functions clears the hook slot so as not to call doubly." + (let* ((hooks (epc:manager-exit-hooks mngr))) + (run-hooks hooks) + (setf (epc:manager-exit-hooks mngr) nil) + mngr)) + +(defun epc:manager-status-server-process (mngr) + "[internal] Return the status of the process object for the peer process. If the process is nil, return nil." + (and mngr + (epc:manager-server-process mngr) + (process-status (epc:manager-server-process mngr)))) + +(defun epc:manager-status-connection-process (mngr) + "[internal] Return the status of the process object for the connection process." + (and (epc:manager-connection mngr) + (process-status (epc:connection-process + (epc:manager-connection mngr))))) + +(defun epc:manager-restart-process (mngr) + "[internal] Restart the process and reconnect." + (cond + ((null (epc:manager-server-process mngr)) + (error "Cannot restart this EPC process!")) + (t + (epc:stop-epc mngr) + (let* ((cmds (epc:manager-commands mngr)) + (new-mngr (epc:start-server (car cmds) (cdr cmds)))) + (setf (epc:manager-server-process mngr) + (epc:manager-server-process new-mngr)) + (setf (epc:manager-port mngr) + (epc:manager-port new-mngr)) + (setf (epc:manager-connection mngr) + (epc:manager-connection new-mngr)) + (setf (epc:manager-methods mngr) + (epc:manager-methods new-mngr)) + (setf (epc:manager-sessions mngr) + (epc:manager-sessions new-mngr)) + (epc:connection-reset (epc:manager-connection mngr)) + (epc:init-epc-layer mngr) + (epc:live-connections-delete new-mngr) + (epc:live-connections-add mngr) + mngr)))) + +(defun epc:manager-send (mngr method &rest messages) + "[internal] low-level message sending." + (let* ((conn (epc:manager-connection mngr))) + (epc:net-send conn (cons method messages)))) + +(defun epc:manager-get-method (mngr method-name) + "[internal] Return a method object. If not found, return nil." + (loop for i in (epc:manager-methods mngr) + if (eq method-name (epc:method-name i)) + do (return i))) + +(defun epc:handler-methods (mngr uid) + "[internal] Return a list of information for registered methods." + (let ((info + (loop for i in (epc:manager-methods mngr) + collect + (list + (epc:method-name i) + (or (epc:method-arg-specs i) "") + (or (epc:method-docstring i) ""))))) + (epc:manager-send mngr 'return uid info))) + +(defun epc:handler-called-method (mngr uid name args) + "[internal] low-level message handler for peer's calling." + (lexical-let ((mngr mngr) (uid uid)) + (let* ((methods (epc:manager-methods mngr)) + (method (epc:manager-get-method mngr name))) + (cond + ((null method) + (epc:log "ERR: No such method : %s" name) + (epc:manager-send mngr 'epc-error uid (format "EPC-ERROR: No such method : %s" name))) + (t + (condition-case err + (let* ((f (epc:method-task method)) + (ret (apply f args))) + (cond + ((deferred-p ret) + (deferred:nextc ret + (lambda (xx) (epc:manager-send mngr 'return uid xx)))) + (t (epc:manager-send mngr 'return uid ret)))) + (error + (epc:log "ERROR : %S" err) + (epc:manager-send mngr 'return-error uid err)))))))) + +(defun epc:manager-remove-session (mngr uid) + "[internal] Remove a session from the epc manager object." + (loop with ret = nil + for pair in (epc:manager-sessions mngr) + unless (eq uid (car pair)) + do (push pair ret) + finally + do (setf (epc:manager-sessions mngr) ret))) + +(defun epc:handler-return (mngr uid args) + "[internal] low-level message handler for normal returns." + (let ((pair (assq uid (epc:manager-sessions mngr)))) + (cond + (pair + (epc:log "RET: id:%s [%S]" uid args) + (epc:manager-remove-session mngr uid) + (deferred:callback (cdr pair) args)) + (t ; error + (epc:log "RET: NOT FOUND: id:%s [%S]" uid args))))) + +(defun epc:handler-return-error (mngr uid args) + "[internal] low-level message handler for application errors." + (let ((pair (assq uid (epc:manager-sessions mngr)))) + (cond + (pair + (epc:log "RET-ERR: id:%s [%S]" uid args) + (epc:manager-remove-session mngr uid) + (deferred:errorback (cdr pair) (format "%S" args))) + (t ; error + (epc:log "RET-ERR: NOT FOUND: id:%s [%S]" uid args))))) + +(defun epc:handler-epc-error (mngr uid args) + "[internal] low-level message handler for epc errors." + (let ((pair (assq uid (epc:manager-sessions mngr)))) + (cond + (pair + (epc:log "RET-EPC-ERR: id:%s [%S]" uid args) + (epc:manager-remove-session mngr uid) + (deferred:errorback (cdr pair) (list 'epc-error args))) + (t ; error + (epc:log "RET-EPC-ERR: NOT FOUND: id:%s [%S]" uid args))))) + + + +(defun epc:call-deferred (mngr method-name args) + "Call peer's method with args asynchronously. Return a deferred +object which is called with the result." + (let ((uid (epc:uid)) + (sessions (epc:manager-sessions mngr)) + (d (deferred:new))) + (push (cons uid d) sessions) + (setf (epc:manager-sessions mngr) sessions) + (epc:manager-send mngr 'call uid method-name args) + d)) + +(defun epc:define-method (mngr method-name task &optional arg-specs docstring) + "Define a method and return a deferred object which is called by the peer." + (let* ((method (make-epc:method + :name method-name :task task + :arg-specs arg-specs :docstring docstring)) + (methods (cons method (epc:manager-methods mngr)))) + (setf (epc:manager-methods mngr) methods) + method)) + +(defun epc:query-methods-deferred (mngr) + "Return a list of information for the peer's methods. +The list is consisted of lists of strings: + (name arg-specs docstring)." + (let ((uid (epc:uid)) + (sessions (epc:manager-sessions mngr)) + (d (deferred:new))) + (push (cons uid d) sessions) + (setf (epc:manager-sessions mngr) sessions) + (epc:manager-send mngr 'methods uid) + d)) + +(defun epc:sync (mngr d) + "Wrap deferred methods with synchronous waiting, and return the result. +If an exception is occurred, this function throws the error." + (lexical-let ((result 'epc:nothing)) + (deferred:$ d + (deferred:nextc it + (lambda (x) (setq result x))) + (deferred:error it + (lambda (er) (setq result (cons 'error er))))) + (while (eq result 'epc:nothing) + (save-current-buffer + (accept-process-output + (epc:connection-process (epc:manager-connection mngr)) + 0 epc:accept-process-timeout t))) + (if (and (consp result) (eq 'error (car result))) + (error (cdr result)) result))) + +(defun epc:call-sync (mngr method-name args) + "Call peer's method with args synchronously and return the result. +If an exception is occurred, this function throws the error." + (epc:sync mngr (epc:call-deferred mngr method-name args))) + +(defun epc:live-p (mngr) + "Return non-nil when MNGR is an EPC manager object with a live +connection." + (let ((proc (ignore-errors + (epc:connection-process (epc:manager-connection mngr))))) + (and (processp proc) + ;; Same as `process-live-p' in Emacs >= 24: + (memq (process-status proc) '(run open listen connect stop))))) + + +;;================================================== +;; Troubleshooting / Debugging support + +(defun epc:pop-to-last-server-process-buffer () + "Open the buffer for most recently started server program process. +This is useful when you want to check why the server program +failed to start (e.g., to see its traceback / error message)." + (interactive) + (let ((buffer (get-buffer (epc:server-buffer-name epc:uid)))) + (if buffer + (pop-to-buffer buffer) + (error "No buffer for the last server process. \ +Probably the EPC connection exits correctly or you didn't start it yet.")))) + + + +;;================================================== +;; Management Interface + +(defun epc:controller () + "Display the management interface for EPC processes and connections. +Process list. +Session status, statistics and uptime. +Peer's method list. +Display process buffer. +Kill sessions and connections. +Restart process." + (interactive) + (let* ((buf-name "*EPC Controller*") + (buf (get-buffer buf-name))) + (unless (buffer-live-p buf) + (setq buf (get-buffer-create buf-name))) + (epc:controller-update-buffer buf) + (pop-to-buffer buf))) + +(defun epc:controller-update-buffer (buf) + "[internal] Update buffer for the current epc processes." + (let* + ((data (loop + for mngr in epc:live-connections collect + (list + (epc:manager-server-process mngr) + (epc:manager-status-server-process mngr) + (epc:manager-status-connection-process mngr) + (epc:manager-title mngr) + (epc:manager-commands mngr) + (epc:manager-port mngr) + (length (epc:manager-methods mngr)) + (length (epc:manager-sessions mngr)) + mngr))) + (param (copy-ctbl:param ctbl:default-rendering-param)) + (cp + (ctbl:create-table-component-buffer + :buffer buf :width nil + :model + (make-ctbl:model + :column-model + (list (make-ctbl:cmodel :title "" :align 'left) + (make-ctbl:cmodel :title "" :align 'center) + (make-ctbl:cmodel :title "" :align 'center) + (make-ctbl:cmodel :title " Title " :align 'left :max-width 30) + (make-ctbl:cmodel :title " Command " :align 'left :max-width 30) + (make-ctbl:cmodel :title " Port " :align 'right) + (make-ctbl:cmodel :title " Methods " :align 'right) + (make-ctbl:cmodel :title " Live sessions " :align 'right)) + :data data) + :custom-map epc:controller-keymap + :param param))) + (pop-to-buffer (ctbl:cp-get-buffer cp)))) + +(eval-when-compile ; introduce anaphoric variable `cp' and `mngr'. + (defmacro epc:controller-with-cp (&rest body) + `(let ((cp (ctbl:cp-get-component))) + (when cp + (let ((mngr (car (last (ctbl:cp-get-selected-data-row cp))))) + ,@body))))) + +(defun epc:controller-update-command () + (interactive) + (epc:controller-with-cp + (epc:controller-update-buffer (current-buffer)))) + +(defun epc:controller-connection-restart-command () + (interactive) + (epc:controller-with-cp + (let* ((proc (epc:manager-server-process mngr)) + (msg (format "Restart the EPC process [%s] ? " proc))) + (when (and proc (y-or-n-p msg)) + (epc:manager-restart-process mngr) + (epc:controller-update-buffer (current-buffer)))))) + +(defun epc:controller-connection-kill-command () + (interactive) + (epc:controller-with-cp + (let* ((proc (epc:manager-server-process mngr)) + (msg (format "Kill the EPC process [%s] ? " proc))) + (when (and proc (y-or-n-p msg)) + (epc:stop-epc mngr) + (epc:controller-update-buffer (current-buffer)))))) + +(defun epc:controller-connection-buffer-command () + (interactive) + (epc:controller-with-cp + (switch-to-buffer + (epc:connection-buffer (epc:manager-connection mngr))))) + +(defun epc:controller-methods-show-command () + (interactive) + (epc:controller-with-cp + (epc:controller-methods mngr))) + +(defun epc:controller-methods (mngr) + "Display a list of methods for the MNGR process." + (let* ((buf-name "*EPC Controller/Methods*") + (buf (get-buffer buf-name))) + (unless (buffer-live-p buf) + (setq buf (get-buffer-create buf-name)) + (with-current-buffer buf + (setq buffer-read-only t))) + (lexical-let ((buf buf) (mngr mngr)) + (deferred:$ + (epc:query-methods-deferred mngr) + (deferred:nextc it + (lambda (methods) + (epc:controller-methods-update-buffer buf mngr methods) + (pop-to-buffer buf))))))) + +(defface epc:face-title + '((((class color) (background light)) + :foreground "Slategray4" :background "Gray90" :weight bold) + (((class color) (background dark)) + :foreground "maroon2" :weight bold)) + "Face for titles" :group 'epc) + +(defun epc:controller-methods-update-buffer (buf mngr methods) + "[internal] Update methods list buffer for the epc process." + (with-current-buffer buf + (let* ((data + (loop for m in methods collect + (list + (car m) + (or (nth 1 m) "") + (or (nth 2 m) "")))) + (param (copy-ctbl:param ctbl:default-rendering-param)) + cp buffer-read-only) + (erase-buffer) + (insert + (propertize + (format "EPC Process : %s\n" + (mapconcat 'identity (epc:manager-commands mngr) " ")) + 'face 'epc:face-title) "\n") + (setq cp (ctbl:create-table-component-region + :model + (make-ctbl:model + :column-model + (list (make-ctbl:cmodel :title "Method Name" :align 'left) + (make-ctbl:cmodel :title "Arguments" :align 'left) + (make-ctbl:cmodel :title "Document" :align 'left)) + :data data) + :keymap epc:controller-methods-keymap + :param param)) + (set (make-local-variable 'epc:mngr) mngr) + (ctbl:cp-set-selected-cell cp '(0 . 0)) + (ctbl:cp-get-buffer cp)))) + +(defun epc:controller-methods-eval-command () + (interactive) + (let ((cp (ctbl:cp-get-component))) + (when cp + (let* ((method-name (car (ctbl:cp-get-selected-data-row cp))) + (args (eval-minibuffer + (format "Arguments for calling [%s] : " method-name)))) + (deferred:$ + (epc:call-deferred epc:mngr method-name args) + (deferred:nextc it + (lambda (ret) (message "Result : %S" ret))) + (deferred:error it + (lambda (err) (message "Error : %S" ret)))))))) + +(defun epc:define-keymap (keymap-list &optional prefix) + "[internal] Keymap utility." + (let ((map (make-sparse-keymap))) + (mapc + (lambda (i) + (define-key map + (if (stringp (car i)) + (read-kbd-macro + (if prefix + (replace-regexp-in-string "prefix" prefix (car i)) + (car i))) + (car i)) + (cdr i))) + keymap-list) + map)) + +(defun epc:add-keymap (keymap keymap-list &optional prefix) + (loop with nkeymap = (copy-keymap keymap) + for i in keymap-list + do + (define-key nkeymap + (if (stringp (car i)) + (read-kbd-macro + (if prefix + (replace-regexp-in-string "prefix" prefix (car i)) + (car i))) + (car i)) + (cdr i)) + finally return nkeymap)) + +(defvar epc:controller-keymap + (epc:define-keymap + '( + ("g" . epc:controller-update-command) + ("R" . epc:controller-connection-restart-command) + ("D" . epc:controller-connection-kill-command) + ("K" . epc:controller-connection-kill-command) + ("m" . epc:controller-methods-show-command) + ("C-m" . epc:controller-methods-show-command) + ("B" . epc:controller-connection-buffer-command) + )) "Keymap for the controller buffer.") + +(defvar epc:controller-methods-keymap + (epc:add-keymap + ctbl:table-mode-map + '( + ("q" . bury-buffer) + ("e" . epc:controller-methods-eval-command) + )) "Keymap for the controller methods list buffer.") + +(provide 'epc) +;;; epc.el ends here diff --git a/conf/emacs.d/jedi.el b/conf/emacs.d/jedi.el new file mode 100644 index 0000000..0e48ceb --- /dev/null +++ b/conf/emacs.d/jedi.el @@ -0,0 +1,995 @@ +;;; jedi.el --- a Python auto-completion for Emacs + +;; Copyright (C) 2012 Takafumi Arakaki + +;; Author: Takafumi Arakaki +;; Package-Requires: ((epc "0.1.0") (auto-complete "1.4")) +;; Version: 0.1.2alpha2 + +;; This file is NOT part of GNU Emacs. + +;; jedi.el 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. + +;; jedi.el 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 jedi.el. +;; If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(require 'epc) +(require 'auto-complete) +(declare-function pos-tip-show "pos-tip") + + +(defgroup jedi nil + "Auto-completion for Python." + :group 'completion + :prefix "jedi:") + +(defconst jedi:version "0.1.2alpha2") + +(defvar jedi:source-dir (if load-file-name + (file-name-directory load-file-name) + default-directory)) + +(defvar jedi:epc nil) +(make-variable-buffer-local 'jedi:epc) + +(defvar jedi:server-script + (convert-standard-filename + (expand-file-name "jediepcserver.py" jedi:source-dir)) + "Full path to Jedi server script file ``jediepcserver.py``.") + + +;;; Configuration variables + +(defcustom jedi:server-command + (list (let ((py (expand-file-name "env/bin/python" jedi:source-dir))) + (if (file-exists-p py) py "python")) + jedi:server-script) + "Command used to run Jedi server. + +If you setup Jedi requirements using ``make requirements`` command, +`jedi:server-command' should be automatically set to:: + + '(\"JEDI:SOURCE-DIR/env/bin/python\" + \"JEDI:SOURCE-DIR/jediepcserver.py\") + +Otherwise, it should be set to:: + + '(\"python\" \"JEDI:SOURCE-DIR/jediepcserver.py\") + +If you want to use your favorite Python executable, set +`jedi:server-command' using:: + + (setq jedi:server-command + (list \"YOUR-FAVORITE-PYTHON\" jedi:server-script)) + +If you want to pass some arguments to the Jedi server command, +use `jedi:server-command'." + :group 'jedi) + +(defcustom jedi:server-args nil + "Command line arguments to be appended to `jedi:server-command'. + +If you want to add some special `sys.path' when starting Jedi +server, do something like this:: + + (setq jedi:server-args + '(\"--sys-path\" \"MY/SPECIAL/PATH\" + \"--sys-path\" \"MY/OTHER/SPECIAL/PATH\")) + +If you want to include some virtualenv, do something like this. +Note that actual `VIRTUAL_ENV' is treated automatically. Also, +you need to start Jedi EPC server with the same python version +that you use for the virtualenv.:: + + (setq jedi:server-args + '(\"--virtual-env\" \"SOME/VIRTUAL_ENV_1\" + \"--virtual-env\" \"SOME/VIRTUAL_ENV_2\")) + +To see what other arguments Jedi server can take, execute the +following command:: + + python jediepcserver.py --help + + +**Advanced usage** + +Sometimes you want to configure how Jedi server is started per +buffer. To do that, you should make this variable buffer local +in `python-mode-hook' and set it to some buffer specific variable, +like this:: + + (defun my-jedi-server-setup () + (let ((cmds (GET-SOME-PROJECT-SPECIFIC-COMMAND)) + (args (GET-SOME-PROJECT-SPECIFIC-ARGS))) + (when cmds (set (make-local-variable 'jedi:server-command) cmds)) + (when args (set (make-local-variable 'jedi:server-args) args)))) + + (add-hook 'python-mode-hook 'my-jedi-server-setup) + +Note that Jedi server run by the same command is pooled. So, +there is only one Jedi server for the same set of command. If +you want to check how many EPC servers are running, use the EPC +GUI: M-x `epc:controller'. You will see a table of EPC connections +for Jedi.el and other EPC applications. + +If you want to start a new ad-hoc server for the current buffer, +use the command `jedi:start-dedicated-server'." + :group 'jedi) + +(defcustom jedi:complete-on-dot nil + "Non-`nil' means automatically start completion after inserting a dot. +To make this option work, you need to use `jedi:setup' instead of +`jedi:ac-setup' to start Jedi." + :group 'jedi) + +(defcustom jedi:tooltip-method '(pos-tip popup) + "Configuration for `jedi:tooltip-show'. +This is a list which may contain symbol(s) `pos-tip' and/or +`popup'. It determines tooltip method to use. Setting this +value to nil means to use minibuffer instead of tooltip." + :group 'jedi) + +(defcustom jedi:get-in-function-call-timeout 3000 + "Cancel request to server for call signature after this period +specified in in millisecond." + :group 'jedi) + +(defcustom jedi:get-in-function-call-delay 1000 + "How long Jedi should wait before showing call signature +tooltip in millisecond." + :group 'jedi) + +(defcustom jedi:goto-definition-config + '((nil nil nil) + (t nil nil) + (nil definition nil) + (t definition nil) + (nil nil t ) + (t nil t ) + (nil definition t ) + (t definition t )) + "Configure how prefix argument modifies `jedi:goto-definition' behavior. + +Each element of the list is arguments (list) passed to +`jedi:goto-definition'. Note that this variable has no effect on +`jedi:goto-definition' when it is used as a lisp function + +The following setting is default (last parts are omitted). +Nth element is used as the argument when N universal prefix +arguments (``C-u``) are given.:: + + (setq jedi:goto-definition-config + '((nil nil nil) ; C-. + (t nil nil) ; C-u C-. + (nil definition nil) ; C-u C-u C-. + (t definition nil) ; C-u C-u C-u C-. + ...)) + +For example, if you want to follow \"substitution path\" by default, +use the setting like this:: + + (setq jedi:goto-definition-config + '((nil definition nil) + (t definition nil) + (nil nil nil) + (t nil nil) + (nil definition t ) + (t definition t ) + (nil nil t ) + (t nil t ))) + +You can rearrange the order to have most useful sets of arguments +at the top." + :group 'jedi) + +(defcustom jedi:doc-mode 'rst-mode + "Major mode to use when showing document." + :group 'jedi) + +(defcustom jedi:doc-hook '(view-mode) + "The hook that's run after showing a document." + :type 'hook + :group 'jedi) + +(defcustom jedi:doc-display-buffer 'display-buffer + "A function to be called with a buffer to show document." + :group 'jedi) + +(defcustom jedi:install-imenu nil + "[EXPERIMENTAL] If `t', use Jedi to create `imenu' index. +To use this feature, you need to install the developmental +version (\"dev\" branch) of Jedi." + :group 'jedi) + +(defcustom jedi:setup-keys nil + "Setup recommended keybinds. + +.. admonition:: Default keybinds + + ```` : = `jedi:key-complete' + Complete code at point. (`jedi:complete') + + ``C-.`` : = `jedi:key-goto-definition' + Goto the definition of the object at point. (`jedi:goto-definition') + + ``C-c d`` : = `jedi:key-show-doc' + Goto the definition of the object at point. (`jedi:show-doc') + + ``C-c r`` : = `jedi:key-related-names' + Find related names of the object at point. + (`helm-jedi-related-names' / `anything-jedi-related-names') + +When `jedi:setup-keys' is non-`nil', recommended keybinds are set +in `jedi-mode-map' when **loading** jedi.el. Therefore, you must +set this value before jedi.el is loaded. As recommended usage of +jedi.el is to call `jedi:setup' via `python-mode-hook' where +`jedi:setup' is autloaded, setting `jedi:setup-keys' to `t' in +you emacs setup (e.g., ``.emacs.d/init.el``) works fine.:: + + (setq jedi:setup-keys t) + (add-hook 'python-mode-hook 'jedi:setup) + +If you want to require jedi.el explicitly when loading Emacs, +make sure to set `jedi:setup-keys' before loading jedi.el:: + + (setq jedi:setup-keys t) + (require 'jedi) + +Byte compiler warns about unbound variable if you set +`jedi:setup-keys' before loading jedi.el. The proper way to +suppress this warning is the following:: + + (eval-when-compile (require 'jedi nil t)) + (setq jedi:setup-keys t) + +You can change these keybinds by changing `jedi:key-complete', +`jedi:key-goto-definition', `jedi:key-show-doc', and +`jedi:key-related-names'. For example, default keybind for +ropemacs's `rope-show-doc' is same as `jedi:show-doc'. You can +avoid collision by something like this:: + + (setq jedi:key-show-doc (kbd \"C-c D\"))" + :group 'jedi) + +(defcustom jedi:key-complete (kbd "") + "Keybind for command `jedi:complete'." + :group 'jedi) + +(defcustom jedi:key-goto-definition (kbd "C-.") + "Keybind for command `jedi:goto-definition'." + :group 'jedi) + +(defcustom jedi:key-show-doc (kbd "C-c d") + "Keybind for command `jedi:show-doc'." + :group 'jedi) + +(defcustom jedi:key-related-names (kbd "C-c r") + "Keybind for command `helm-jedi-related-names' or +`anything-jedi-related-names'." + :group 'jedi) + +(defcustom jedi:import-python-el-settings t + "Automatically import setting from python.el variables." + :group 'jedi) + + +;;; Internal variables + +(defvar jedi:get-in-function-call--d nil + "Bounded to deferred object while requesting get-in-function-call.") + +(defvar jedi:defined-names--singleton-d nil + "Bounded to deferred object while requesting defined_names.") + + +;;; Jedi mode + +(defvar jedi-mode-map (make-sparse-keymap)) + +(defun jedi:handle-post-command () + (jedi:get-in-function-call-when-idle)) + +(define-minor-mode jedi-mode + "Jedi mode. +When `jedi-mode' is on, call signature is automatically shown as +toolitp when inside of function call. + +\\{jedi-mode-map}" + :keymap jedi-mode-map + :group 'jedi + (let ((map jedi-mode-map)) + (if jedi:complete-on-dot + (define-key map "." 'jedi:dot-complete) + (define-key map "." nil))) + (if jedi-mode + (progn + (when jedi:install-imenu + (add-hook 'after-change-functions 'jedi:after-change-handler nil t) + (jedi:defined-names-deferred) + (setq imenu-create-index-function 'jedi:create-imenu-index)) + (add-hook 'post-command-hook 'jedi:handle-post-command nil t) + (add-hook 'kill-buffer-hook 'jedi:server-pool--gc-when-idle nil t)) + (remove-hook 'post-command-hook 'jedi:handle-post-command t) + (remove-hook 'after-change-functions 'jedi:after-change-handler t) + (remove-hook 'kill-buffer-hook 'jedi:server-pool--gc-when-idle t) + (jedi:server-pool--gc-when-idle))) + +(when jedi:setup-keys + (let ((map jedi-mode-map)) + (define-key map jedi:key-complete 'jedi:complete) + (define-key map jedi:key-goto-definition 'jedi:goto-definition) + (define-key map jedi:key-show-doc 'jedi:show-doc) + (let ((command (cond + ((featurep 'helm) 'helm-jedi-related-names) + ((featurep 'anything) 'anything-jedi-related-names)))) + (when command + (define-key map jedi:key-related-names command))))) + + +;;; EPC utils + +(defun jedi:epc--live-p (mngr) + "Return non-nil when MNGR is an EPC manager object with a live +connection." + (let ((proc (ignore-errors + (epc:connection-process (epc:manager-connection mngr))))) + (and (processp proc) + ;; Same as `process-live-p' in Emacs >= 24: + (memq (process-status proc) '(run open listen connect stop))))) + +(defun jedi:epc--start-epc (server-prog server-args) + "Same as `epc:start-epc', but set query-on-exit flag for +associated processes to nil." + (let ((mngr (epc:start-epc server-prog server-args))) + (set-process-query-on-exit-flag (epc:connection-process + (epc:manager-connection mngr)) + nil) + (set-process-query-on-exit-flag (epc:manager-server-process mngr) nil) + mngr)) + + +;;; Server pool + +(defvar jedi:server-pool--table (make-hash-table :test 'equal) + "A hash table that holds a pool of EPC server instances.") + +(defun jedi:server-pool--start (command) + "Get an EPC server instance from server pool by COMMAND as a +key, or start new one if there is none." + (let ((cached (gethash command jedi:server-pool--table))) + (if (and cached (jedi:epc--live-p cached)) + cached + (let* ((default-directory jedi:source-dir) + (mngr (jedi:epc--start-epc (car command) (cdr command)))) + (puthash command mngr jedi:server-pool--table) + (jedi:server-pool--gc-when-idle) + mngr)))) + +(defun jedi:-get-servers-in-use () + "Return a list of non-nil `jedi:epc' in all buffers." + (loop with mngr-list + for buffer in (buffer-list) + for mngr = (with-current-buffer buffer jedi:epc) + when (and mngr (not (memq mngr mngr-list))) + collect mngr into mngr-list + finally return mngr-list)) + +(defvar jedi:server-pool--gc-timer nil) + +(defun jedi:server-pool--gc () + "Stop unused servers." + (let ((servers-in-use (jedi:-get-servers-in-use))) + (maphash + (lambda (key mngr) + (unless (memq mngr servers-in-use) + (remhash key jedi:server-pool--table) + (epc:stop-epc mngr))) + jedi:server-pool--table)) + ;; Clear timer so that GC is started next time + ;; `jedi:server-pool--gc-when-idle' is called. + (setq jedi:server-pool--gc-timer nil)) + +(defun jedi:server-pool--gc-when-idle () + "Run `jedi:server-pool--gc' when idle." + (unless jedi:server-pool--gc-timer + (setq jedi:server-pool--gc-timer + (run-with-idle-timer 10 nil 'jedi:server-pool--gc)))) + + +;;; Server management + +(defun jedi:start-server () + (if (jedi:epc--live-p jedi:epc) + (message "Jedi server is already started!") + (setq jedi:epc (jedi:server-pool--start + (append jedi:server-command jedi:server-args)))) + jedi:epc) + +(defun jedi:stop-server () + "Stop Jedi server. Use this command when you want to restart +Jedi server (e.g., when you changed `jedi:server-command' or +`jedi:server-args'). Jedi srever will be restarted automatically +later when it is needed." + (interactive) + (if jedi:epc + (epc:stop-epc jedi:epc) + (message "Jedi server is already killed.")) + (setq jedi:epc nil) + ;; It could be non-nil due to some error. Rescue it in that case. + (setq jedi:get-in-function-call--d nil) + (setq jedi:defined-names--singleton-d nil)) + +(defun jedi:get-epc () + (if (jedi:epc--live-p jedi:epc) + jedi:epc + (jedi:start-server))) + +;;;###autoload +(defun jedi:start-dedicated-server (command) + "Start Jedi server dedicated to this buffer. +This is useful, for example, when you want to use different +`sys.path' for some buffer. When invoked as an interactive +command, it asks you how to start the Jedi server. You can edit +the command in minibuffer to specify the way Jedi server run. + +If you want to setup how Jedi server is started programmatically +per-buffer/per-project basis, make `jedi:server-command' and +`jedi:server-args' buffer local and set it in `python-mode-hook'. +See also: `jedi:server-args'." + (interactive + (list (split-string-and-unquote + (read-string "Run Jedi server: " + (mapconcat + #'identity + (append jedi:server-command + jedi:server-args) + " "))))) + ;; Reset `jedi:epc' so that a new server is created when COMMAND is + ;; new. If it is already in the server pool, the server instance + ;; already in the pool is picked up by `jedi:start-server'. + (setq jedi:epc nil) + ;; Set `jedi:server-command', so that this command is used + ;; when restarting EPC server of this buffer. + (set (make-local-variable 'jedi:server-command) command) + (set (make-local-variable 'jedi:server-args) nil) + (jedi:start-server)) + +(defun jedi:call-deferred (method-name) + "Call ``Script(...).METHOD-NAME`` and return a deferred object." + (let ((source (buffer-substring-no-properties (point-min) (point-max))) + (line (count-lines (point-min) (min (1+ (point)) (point-max)))) + (column (current-column)) + (source-path buffer-file-name)) + (epc:call-deferred (jedi:get-epc) + method-name + (list source line column source-path)))) + + +;;; Completion + +(defvar jedi:complete-reply nil + "Last reply to `jedi:complete-request'.") + +(defvar jedi:complete-request-point 0 + ;; It is passed to `=', so do not initialize this value by `nil'. + "The point where `jedi:complete-request' is called.") + +(defun jedi:complete-request () + "Request ``Script(...).complete`` and return a deferred object. +`jedi:complete-reply' is set to the reply sent from the server." + (setq jedi:complete-request-point (point)) + (deferred:nextc (jedi:call-deferred 'complete) + (lambda (reply) + (setq jedi:complete-reply reply)))) + +;;;###autoload +(defun* jedi:complete (&key (expand ac-expand-on-auto-complete)) + "Complete code at point." + (interactive) + (lexical-let ((expand expand)) + (deferred:nextc (jedi:complete-request) + (lambda () + (let ((ac-expand-on-auto-complete expand)) + (auto-complete '(ac-source-jedi-direct))))))) + +(defun jedi:dot-complete () + "Insert dot and complete code at point." + (interactive) + (insert ".") + (unless (ac-cursor-on-diable-face-p) + (jedi:complete :expand nil))) + + +;;; AC source + +(defun jedi:ac-direct-matches () + (mapcar + (lambda (x) + (destructuring-bind (&key word doc description symbol) + x + (popup-make-item word + :symbol symbol + :document (unless (equal doc "") doc) + :summary description))) + jedi:complete-reply)) + +(defun jedi:ac-direct-prefix () + (or (ac-prefix-default) + (when (= jedi:complete-request-point (point)) + jedi:complete-request-point))) + +;; (makunbound 'ac-source-jedi-direct) +(ac-define-source jedi-direct + '((candidates . jedi:ac-direct-matches) + (prefix . jedi:ac-direct-prefix) + (init . jedi:complete-request) + (requires . -1))) + +;;;###autoload +(defun jedi:ac-setup () + "Add Jedi AC sources to `ac-sources'." + (interactive) + (add-to-list 'ac-sources 'ac-source-jedi-direct)) + + +;;; Call signature (get_in_function_call) + +(defface jedi:highlight-function-argument + '((t (:inherit bold))) + "Face used for the argument at point in a function's argument list" + :group 'jedi) + +(defun* jedi:get-in-function-call--construct-call-signature + (&key params index call_name) + (let ((current-arg (nth index params))) + (when (and current-arg (null jedi:tooltip-method)) + (setf (nth index params) + (propertize current-arg 'face 'jedi:highlight-function-argument))) + (concat call_name "(" (mapconcat #'identity params ", ") ")"))) + +(defun jedi:get-in-function-call--tooltip-show (args) + (when (and args (not ac-completing)) + (jedi:tooltip-show + (apply #'jedi:get-in-function-call--construct-call-signature args)))) + +(defun jedi:get-in-function-call () + "Manually show call signature tooltip." + (interactive) + (deferred:nextc + (jedi:call-deferred 'get_in_function_call) + #'jedi:get-in-function-call--tooltip-show)) + +(defun jedi:get-in-function-call-when-idle () + "Show tooltip when Emacs is ilde." + (unless jedi:get-in-function-call--d + (setq jedi:get-in-function-call--d + (deferred:try + (deferred:$ + (deferred:wait-idle jedi:get-in-function-call-delay) + (deferred:nextc it + (lambda () + (when jedi-mode ; cursor may be moved + (deferred:timeout + jedi:get-in-function-call-timeout + nil + (jedi:call-deferred 'get_in_function_call))))) + (deferred:nextc it #'jedi:get-in-function-call--tooltip-show)) + :finally + (lambda () + (setq jedi:get-in-function-call--d nil)))))) + +(defun jedi:tooltip-show (string) + (cond + ((and (memq 'pos-tip jedi:tooltip-method) window-system + (featurep 'pos-tip)) + (pos-tip-show (jedi:string-fill-paragraph string) + 'popup-tip-face nil nil 0)) + ((and (memq 'popup jedi:tooltip-method) + (featurep 'popup)) + (popup-tip string)) + (t (when (stringp string) + (let ((message-log-max nil)) + (message string)))))) + +(defun jedi:string-fill-paragraph (string &optional justify) + (with-temp-buffer + (erase-buffer) + (insert string) + (goto-char (point-min)) + (fill-paragraph justify) + (buffer-string))) + + +;;; Goto + +(defvar jedi:goto-definition--index nil) +(defvar jedi:goto-definition--cache nil) + +(defun jedi:goto-definition (&optional other-window deftype use-cache index) + "Goto the definition of the object at point. + +See `jedi:goto-definition-config' for how this function works +when universal prefix arguments \(``C-u``) are given. If +*numeric* prefix argument(s) \(e.g., ``M-0``) are given, goto +point of the INDEX-th result. Note that you cannot mix universal +and numeric prefixes. It is Emacs's limitation. If you mix both +kinds of prefix, you get numeric prefix. + +When used as a lisp function, popup a buffer when OTHER-WINDOW is +non-nil. DEFTYPE must be either `assignment' (default) or +`definition'. When USE-CACHE is non-nil, use the locations of +the last invocation of this command. If INDEX is specified, goto +INDEX-th result." + (interactive + (if (integerp current-prefix-arg) + (list nil nil nil current-prefix-arg) + (nth (let ((i (car current-prefix-arg))) + (if i (floor (log i 4)) 0)) + jedi:goto-definition-config))) + (cond + ((and (or use-cache index) + jedi:goto-definition--cache) + (setq jedi:goto-definition--index (or index 0)) + (jedi:goto-definition--nth other-window)) + ((and (eq last-command 'jedi:goto-definition) + (> (length jedi:goto-definition--cache) 1)) + (jedi:goto-definition-next other-window)) + (t + (setq jedi:goto-definition--index (or index 0)) + (lexical-let ((other-window other-window)) + (deferred:nextc (jedi:call-deferred + (case deftype + ((assignment nil) 'goto) + (definition 'get_definition) + (t (error "Unsupported deftype: %s" deftype)))) + (lambda (reply) + (jedi:goto-definition--callback reply other-window))))))) + +(defun jedi:goto-definition-next (&optional other-window) + "Goto the next cached definition. See: `jedi:goto-definition'." + (interactive "P") + (let ((len (length jedi:goto-definition--cache)) + (n (1+ jedi:goto-definition--index))) + (setq jedi:goto-definition--index (if (>= n len) 0 n)) + (jedi:goto-definition--nth other-window))) + +(defun jedi:goto-definition--callback (reply other-window) + (if (not reply) + (message "Definition not found.") + (setq jedi:goto-definition--cache reply) + (jedi:goto-definition--nth other-window t))) + +(defun jedi:goto--line-column (line column) + "Like `goto-char' but specify the position by LINE and COLUMN." + (goto-char (point-min)) + (forward-line (1- line)) + (forward-char column)) + +(defun jedi:goto-definition--nth (other-window &optional try-next) + (let* ((len (length jedi:goto-definition--cache)) + (n jedi:goto-definition--index) + (next (lambda () + (when (< n (1- len)) + (incf jedi:goto-definition--index) + (jedi:goto-definition--nth other-window) + t)))) + (destructuring-bind (&key line_nr column module_path module_name + &allow-other-keys) + (nth n jedi:goto-definition--cache) + (cond + ((equal module_name "__builtin__") + (unless (and try-next (funcall next)) + (message "Cannot see the definition of __builtin__."))) + ((not (and module_path (file-exists-p module_path))) + (unless (and try-next (funcall next)) + (message "File '%s' does not exist." module_path))) + (t + (push-mark) + (funcall (if other-window #'find-file-other-window #'find-file) + module_path) + (jedi:goto--line-column line_nr column) + (jedi:goto-definition--notify-alternatives len n)))))) + +(defun jedi:goto-definition--notify-alternatives (len n) + (unless (= len 1) + (message + "%d-th point in %d candidates.%s" + (1+ n) + len + ;; Note: It must be `last-command', not `last-command' because + ;; this function is called in deferred at the first time. + (if (eq last-command 'jedi:goto-definition) + (format " Type %s to go to the next point." + (key-description + (car (where-is-internal 'jedi:goto-definition)))) + "")))) + + +;;; Full name + +(defun jedi:get-full-name-deferred () + (deferred:$ + (jedi:call-deferred 'get_definition) + (deferred:nextc it + (lambda (reply) + (loop for def in reply + do (destructuring-bind (&key full_name &allow-other-keys) + def + (when full_name + (return full_name)))))))) + +(defun* jedi:get-full-name-sync (&key (timeout 500)) + (epc:sync + (jedi:get-epc) + (deferred:timeout timeout nil (jedi:get-full-name-deferred)))) + + +;;; Related names + +(defun jedi:related-names--source (name candidates) + `((name . ,name) + (candidates . ,candidates) + (recenter) + (type . file-line))) + +(defun jedi:related-names--to-file-line (reply) + (mapcar + (lambda (x) + (destructuring-bind + (&key line_nr column module_name module_path description) + x + (format "%s:%s: %s - %s" module_path line_nr + module_name description))) + reply)) + +(defun jedi:related-names--helm (helm) + (lexical-let ((helm helm)) + (deferred:nextc + (let ((to-file-line #'jedi:related-names--to-file-line)) + (deferred:parallel + (deferred:nextc (jedi:call-deferred 'related_names) to-file-line) + (deferred:nextc (jedi:call-deferred 'goto) to-file-line))) + (lambda (candidates-list) + (funcall + helm + :sources (list (jedi:related-names--source "Jedi Related Names" + (car candidates-list)) + (jedi:related-names--source "Jedi Goto" + (cadr candidates-list))) + :buffer (format "*%s jedi:related-names*" helm)))))) + +;;;###autoload +(defun helm-jedi-related-names () + "Find related names of the object at point using `helm' interface." + (interactive) + (jedi:related-names--helm 'helm)) + +;;;###autoload +(defun anything-jedi-related-names () + "Find related names of the object at point using `anything' interface." + (interactive) + (jedi:related-names--helm 'anything)) + + +;;; Show document (get-definition) + +(defvar jedi:doc-buffer-name "*jedi:doc*") + +(defun jedi:show-doc () + "Show the documentation of the object at point." + (interactive) + (deferred:nextc (jedi:call-deferred 'get_definition) + (lambda (reply) + (with-current-buffer (get-buffer-create jedi:doc-buffer-name) + (loop with has-doc = nil + with first = t + with inhibit-read-only = t + initially (erase-buffer) + for def in reply + do (destructuring-bind + (&key doc desc_with_module line_nr module_path + &allow-other-keys) + def + (unless (or (null doc) (equal doc "")) + (if first + (setq first nil) + (insert "\n\n---\n\n")) + (insert "Docstring for " desc_with_module "\n\n" doc) + (setq has-doc t))) + finally do + (if (not has-doc) + (message "Document not found.") + (progn + (goto-char (point-min)) + (when (fboundp jedi:doc-mode) + (funcall jedi:doc-mode)) + (run-hooks 'jedi:doc-hook) + (funcall jedi:doc-display-buffer (current-buffer))))))))) + + +;;; Defined names (imenu) + +(defvar jedi:defined-names--cache nil) +(make-variable-buffer-local 'jedi:defined-names--cache) + +(defun jedi:defined-names-deferred () + (deferred:nextc + (epc:call-deferred + (jedi:get-epc) + 'defined_names + (list (buffer-substring-no-properties (point-min) (point-max)) + buffer-file-name)) + (lambda (reply) + (setq jedi:defined-names--cache reply)))) + +(defun jedi:defined-names--singleton-deferred () + "Like `jedi:defined-names-deferred', but make sure that only +one request at the time is emitted." + (unless jedi:defined-names--singleton-d + (setq jedi:defined-names--singleton-d + (deferred:watch (jedi:defined-names-deferred) + (lambda (_) (setq jedi:defined-names--singleton-d nil)))))) + +(defun jedi:after-change-handler (&rest _) + (unless (or (ac-menu-live-p) (ac-inline-live-p)) + (jedi:defined-names--singleton-deferred))) + +(defun jedi:create-imenu-index-1 (def) + (destructuring-bind (&key name line_nr column &allow-other-keys) def + (cons name (save-excursion (jedi:goto--line-column line_nr column) + (point-marker))))) + +(defun jedi:create-imenu-index (&optional items) + "`imenu-create-index-function' for Jedi.el. +Return an object described in `imenu--index-alist'." + (loop for (def . subdefs) in (or items jedi:defined-names--cache) + if subdefs + collect (append + (list (plist-get def :full_name) + (jedi:create-imenu-index-1 def)) + (jedi:create-imenu-index subdefs)) + else + collect (jedi:create-imenu-index-1 def))) + + +;;; Meta info + +(defun jedi:get-jedi-version-request () + "Request version of Python modules and return a deferred object." + (epc:call-deferred (jedi:get-epc) 'get_jedi_version nil)) + +(defun jedi:show-jedi-version () + (interactive) + (deferred:nextc (jedi:get-jedi-version-request) + (lambda (reply) + (let ((standard-output (get-buffer-create "*jedi:version*"))) + (with-current-buffer standard-output + (emacs-lisp-mode) + (erase-buffer) + (pp reply) + (display-buffer standard-output)))))) + +(defun jedi:print-jedi-version () + (pp (epc:sync (jedi:get-epc) (jedi:get-jedi-version-request)))) + + +;;; Setup + +(defun jedi:import-python-el-settings-setup () + "Make jedi aware of python.el virtualenv and path settings. +This is automatically added to the `jedi-mode-hook' when +`jedi:import-python-el-settings' is non-nil." + (let ((args)) + (when (bound-and-true-p python-shell-extra-pythonpaths) + (mapc + (lambda (path) + (setq args (append (list "--sys-path" path) args))) + python-shell-extra-pythonpaths)) + (when (bound-and-true-p python-shell-virtualenv-path) + (setq args + (append + (list "--virtual-env" python-shell-virtualenv-path) + args))) + (when args + (set (make-local-variable 'jedi:server-args) + (append args jedi:server-args))))) + +;;;###autoload +(defun jedi:setup () + "Fully setup jedi.el for current buffer. +It setups `ac-sources' (calls `jedi:ac-setup') and turns +`jedi-mode' on. + +This function is intended to be called from `python-mode-hook', +like this:: + + (add-hook 'python-mode-hook 'jedi:setup) + +You can also call this function as a command, to quickly test +what jedi can do." + (interactive) + (jedi:ac-setup) + (when jedi:import-python-el-settings + ;; Hack to access buffer/dir-local vars: http://bit.ly/Y5IfMV. + ;; Given that `jedi:setup' is added to the `python-mode-hook' + ;; this will modify `hack-local-variables-hook' on python + ;; buffers only and will allow us to access buffer/directory + ;; local variables in `jedi:import-python-el-settings-setup'. + (add-hook 'hack-local-variables-hook + #'jedi:import-python-el-settings-setup nil t)) + (jedi-mode 1)) + + +;;; Debugging + + +(defvar jedi:server-command--backup nil) +(defvar jedi:server-args--backup nil) + +(defun jedi:toggle-debug-server () + "Setup `jedi:server-command' and `jedi:server-args' to debug +server using pdb or ipdb. + +When this command is called, it essentially execute the following +code:: + + (jedi:stop-server) + (setq jedi:server-command (list \"cat\" \"jedi-port.log\" ) + jedi:server-args nil) + +It means to pass the port number recorded in the file +jedi-port.log to EPC client. + +To start Jedi server in terminal and record port to the file, +use the following command:: + + python jediepcserver.py --port-file jedi-port.log --pdb + +This command will be copied in the kill-ring (clipboard) when +this command is called. You can use `--ipdb` instead of `--pdb` +to use ipdb instead of pdb. + +Calling this command again restores the original setting of +`jedi:server-command' and `jedi:server-args' then stops the +running server." + (interactive) + (if jedi:server-command--backup + (progn + (setq jedi:server-command jedi:server-command--backup + jedi:server-args jedi:server-args--backup) + (jedi:stop-server) + (message "Quit debugging. Original setting restored.")) + (setq jedi:server-command--backup jedi:server-command + jedi:server-args--backup jedi:server-args + jedi:server-command (list "cat" (expand-file-name + "jedi-port.log" jedi:source-dir)) + jedi:server-args nil) + (jedi:stop-server) + (kill-new "python jediepcserver.py --port-file jedi-port.log --ipdb") + (message "Now, start server with: --port-file jedi-port.log --ipdb.\ + (command is copied in the kill-ring)"))) + + +(provide 'jedi) + +;; Local Variables: +;; coding: utf-8 +;; indent-tabs-mode: nil +;; End: + +;;; jedi.el ends here diff --git a/conf/emacs.d/jediepcserver.py b/conf/emacs.d/jediepcserver.py new file mode 100644 index 0000000..63c0936 --- /dev/null +++ b/conf/emacs.d/jediepcserver.py @@ -0,0 +1,299 @@ +""" +Jedi EPC server. + +Copyright (C) 2012 Takafumi Arakaki + +Author: Takafumi Arakaki + +This file is NOT part of GNU Emacs. + +Jedi EPC server 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. + +Jedi EPC server 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 Jedi EPC server. +If not, see . + +""" + +import os +import sys +import re +import itertools +import logging +import site + +jedi = None # I will load it later + + +PY3 = (sys.version_info[0] >= 3) +NEED_ENCODE = not PY3 + + +def jedi_script(source, line, column, source_path): + if NEED_ENCODE: + source = source.encode('utf-8') + source_path = source_path and source_path.encode('utf-8') + return jedi.Script(source, line, column, source_path or '') + + +def candidate_symbol(comp): + """ + Return a character representing completion type. + + :type comp: jedi.api.Completion + :arg comp: A completion object returned by `jedi.Script.complete`. + + """ + try: + return comp.type[0].lower() + except (AttributeError, TypeError): + return '?' + + +def candidates_description(comp): + """ + Return `comp.description` in an appropriate format. + + * Avoid return a string 'None'. + * Strip off all newlines. This is required for using + `comp.description` as candidate summary. + + """ + desc = comp.description + return _WHITESPACES_RE.sub(' ', desc) if desc and desc != 'None' else '' +_WHITESPACES_RE = re.compile(r'\s+') + + +def complete(*args): + reply = [] + for comp in jedi_script(*args).complete(): + reply.append(dict( + word=comp.word, + doc=comp.doc, + description=candidates_description(comp), + symbol=candidate_symbol(comp), + )) + return reply + + +def get_in_function_call(*args): + call_def = jedi_script(*args).get_in_function_call() + if call_def: + return dict( + # p.get_code(False) should do the job. But jedi-vim use replace. + # So follow what jedi-vim does... + params=[p.get_code().replace('\n', '') for p in call_def.params], + index=call_def.index, + call_name=call_def.call_name, + ) + else: + return [] # nil + + +def _goto(method, *args): + """ + Helper function for `goto` and `related_names`. + + :arg method: `jedi.Script.goto` or `jedi.Script.related_names` + :arg args: Arguments to `jedi_script` + + """ + # `definitions` is a list. Each element is an instances of + # `jedi.api_classes.BaseOutput` subclass, i.e., + # `jedi.api_classes.RelatedName` or `jedi.api_classes.Definition`. + definitions = method(jedi_script(*args)) + return [dict( + column=d.column, + line_nr=d.line_nr, + module_path=d.module_path if d.module_path != '__builtin__' else [], + module_name=d.module_name, + description=d.description, + ) for d in definitions] + + +def goto(*args): + return _goto(jedi.Script.goto, *args) + + +def related_names(*args): + return _goto(jedi.Script.related_names, *args) + + +def definition_to_dict(d): + return dict( + doc=d.doc, + description=d.description, + desc_with_module=d.desc_with_module, + line_nr=d.line_nr, + column=d.column, + module_path=d.module_path, + name=getattr(d, 'name', []), + full_name=getattr(d, 'full_name', []), + type=getattr(d, 'type', []), + ) + + +def get_definition(*args): + definitions = jedi_script(*args).get_definition() + return list(map(definition_to_dict, definitions)) + + +def get_names_recursively(definition): + """ + Fetch interesting defined names in sub-scopes under `definition`. + + :type names: jedi.api_classes.Definition + + """ + d = definition_to_dict(definition) + # FIXME: use appropriate method to do this (when Jedi implement some) + if definition.description.startswith('class '): + ds = definition.defined_names() + return [d] + list(map(get_names_recursively, ds)) + else: + return [d] + + +def defined_names(*args): + return list(map(get_names_recursively, jedi.api.defined_names(*args))) + + +def get_module_version(module): + try: + from pkg_resources import get_distribution, DistributionNotFound + try: + return get_distribution(module.__name__).version + except DistributionNotFound: + pass + except ImportError: + pass + + notfound = object() + for key in ['__version__', 'version']: + version = getattr(module, key, notfound) + if version is not notfound: + return version + + +def get_jedi_version(): + import epc + import sexpdata + return [dict( + name=module.__name__, + file=getattr(module, '__file__', []), + version=get_module_version(module) or [], + ) for module in [sys, jedi, epc, sexpdata]] + + +def jedi_epc_server(address='localhost', port=0, port_file=sys.stdout, + sys_path=[], virtual_env=[], + debugger=None, log=None, log_level=None): + add_virtualenv_path() + for p in virtual_env: + add_virtualenv_path(p) + sys_path = map(os.path.expandvars, map(os.path.expanduser, sys_path)) + sys.path = [''] + list(filter(None, itertools.chain(sys_path, sys.path))) + # Workaround Jedi's module cache. Use this workaround until Jedi + # got an API to set module paths. + # See also: https://github.com/davidhalter/jedi/issues/36 + import_jedi() + import epc.server + server = epc.server.EPCServer((address, port)) + server.register_function(complete) + server.register_function(get_in_function_call) + server.register_function(goto) + server.register_function(related_names) + server.register_function(get_definition) + server.register_function(defined_names) + server.register_function(get_jedi_version) + + port_file.write(str(server.server_address[1])) # needed for Emacs client + port_file.write("\n") + port_file.flush() + if port_file is not sys.stdout: + port_file.close() + + if log: + server.log_traceback = True + handler = logging.FileHandler(filename=log, mode='w') + if log_level: + log_level = getattr(logging, log_level.upper()) + handler.setLevel(log_level) + server.logger.setLevel(log_level) + server.logger.addHandler(handler) + if debugger: + server.set_debugger(debugger) + handler = logging.StreamHandler() + handler.setLevel(logging.DEBUG) + server.logger.addHandler(handler) + server.logger.setLevel(logging.DEBUG) + + server.serve_forever() + server.logger.info('exit') + return server + + +def import_jedi(): + global jedi + import jedi + import jedi.parsing + import jedi.evaluate + import jedi.api + return jedi + + +def add_virtualenv_path(venv=os.getenv('VIRTUAL_ENV')): + """Add virtualenv's site-packages to `sys.path`.""" + if not venv: + return + venv = os.path.abspath(venv) + path = os.path.join( + venv, 'lib', 'python%d.%d' % sys.version_info[:2], 'site-packages') + sys.path.insert(0, path) + site.addsitedir(path) + + +def main(args=None): + import argparse + parser = argparse.ArgumentParser( + formatter_class=argparse.RawTextHelpFormatter, + description=__doc__) + parser.add_argument( + '--address', default='localhost') + parser.add_argument( + '--port', default=0, type=int) + parser.add_argument( + '--port-file', '-f', default='-', type=argparse.FileType('wt'), + help='file to write port on. default is stdout.') + parser.add_argument( + '--sys-path', '-p', default=[], action='append', + help='paths to be inserted at the top of `sys.path`.') + parser.add_argument( + '--virtual-env', '-v', default=[], action='append', + help='paths to be used as if VIRTUAL_ENV is set to it.') + parser.add_argument( + '--log', help='save server log to this file.') + parser.add_argument( + '--log-level', + choices=['CRITICAL', 'ERROR', 'WARN', 'INFO', 'DEBUG'], + help='logging level for log file.') + parser.add_argument( + '--pdb', dest='debugger', const='pdb', action='store_const', + help='start pdb when error occurs.') + parser.add_argument( + '--ipdb', dest='debugger', const='ipdb', action='store_const', + help='start ipdb when error occurs.') + ns = parser.parse_args(args) + jedi_epc_server(**vars(ns)) + + +if __name__ == '__main__': + main() diff --git a/conf/emacs.d/snippets/text-mode/js-mode/log.yasnippet b/conf/emacs.d/snippets/text-mode/js-mode/log.yasnippet index 19ff1be..b1d9f21 100644 --- a/conf/emacs.d/snippets/text-mode/js-mode/log.yasnippet +++ b/conf/emacs.d/snippets/text-mode/js-mode/log.yasnippet @@ -2,4 +2,4 @@ # name: log # key: log # -- -console.${1:log}( $0 ); +console.${1:log}($0); diff --git a/conf/emacs.d/test-jedi.el b/conf/emacs.d/test-jedi.el new file mode 100644 index 0000000..8f83239 --- /dev/null +++ b/conf/emacs.d/test-jedi.el @@ -0,0 +1,254 @@ +;;; test-jedi.el --- Tests for jedi.el + +;; Copyright (C) 2012 Takafumi Arakaki + +;; Author: Takafumi Arakaki + +;; This file is NOT part of GNU Emacs. + +;; test-jedi.el 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. + +;; test-jedi.el 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 test-jedi.el. +;; If not, see . + +;;; Commentary: + +;; + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'ert) + +(require 'mocker) + +(require 'jedi) + + +(defun jedi-testing:sync (d) + (epc:sync (jedi:get-epc) d)) + +(ert-deftest jedi:version () + "Check if `jedi:version' can be parsed by `version-to-list'." + (version-to-list jedi:version)) + + +;;; EPC + +(ert-deftest jedi:complete-request () + (jedi-testing:sync + (with-temp-buffer + (erase-buffer) + (insert "import json" "\n" "json.l") + (jedi:complete-request))) + (should (equal (sort (jedi:ac-direct-matches) #'string-lessp) + '("load" "loads")))) + +(ert-deftest jedi:get-in-function-call-request () + (destructuring-bind (&key params index call_name) + (jedi-testing:sync + (with-temp-buffer + (erase-buffer) + (insert "isinstance(obj,") + (jedi:call-deferred 'get_in_function_call))) + (should (equal params '("object" "class_or_type_or_tuple"))) + (should (equal index 1)) + (should (equal call_name "isinstance")))) + +(ert-deftest jedi:goto-request () + (let ((reply + (jedi-testing:sync + (with-temp-buffer + (erase-buffer) + (insert "import json" "\n" "json.load") + (jedi:call-deferred 'goto))))) + (destructuring-bind (&key line_nr module_path + column module_name description) + (car reply) + (should (integerp line_nr)) + (should (stringp module_path))))) + +(ert-deftest jedi:get-definition-request () + (let ((reply + (jedi-testing:sync + (with-temp-buffer + (erase-buffer) + (insert "import json" "\n" "json.load") + (jedi:call-deferred 'get_definition))))) + (destructuring-bind (&key doc desc_with_module line_nr column module_path + full_name name type description) + (car reply) + (should (stringp doc)) + (should (stringp desc_with_module)) + (should (integerp line_nr)) + (should (integerp column)) + (should (stringp module_path))))) + + +;;; Server pool + +(defmacro jedi-testing:with-mocked-server (start-epc-records + epc--live-p-records + buffers + &rest body) + (declare (indent 3)) + `(let ((jedi:server-pool--table (make-hash-table :test 'equal)) + (jedi:server-pool--gc-timer nil) + ,@(mapcar + (lambda (b) `(,b (generate-new-buffer "*jedi test*"))) + buffers)) + (mocker-let + ((jedi:epc--start-epc (x y) ,start-epc-records) + (jedi:epc--live-p (x) ,epc--live-p-records) + ;; Probably this mocking is too "strong". What I need to + ;; mock is only `buffer-list' in `jedi:-get-servers-in-use'. + (buffer-list + () + ((:input nil + :output-generator + (lambda () + (loop for b in (list ,@buffers) + when (buffer-live-p b) collect b)) + :min-occur 0))) + (jedi:server-pool--gc-when-idle + () + ((:record-cls 'mocker-stub-record)))) + (macrolet ((check-restart (&rest args) + `(jedi-testing:check-start-server ,@args)) + (set-server + (command &optional args) + `(progn + (set (make-local-variable 'jedi:server-command) ,command) + (set (make-local-variable 'jedi:server-args) ,args)))) + (unwind-protect + (progn ,@body) + (mapc #'kill-buffer (list ,@buffers))))))) + +(defun jedi-testing:check-start-server (buffer command server) + (with-current-buffer buffer + (should-not jedi:epc) + (should (eq (let ((jedi:server-command command) + (jedi:server-args nil)) + (jedi:start-server)) + server)) + (should (eq jedi:epc server)))) + +(ert-deftest jedi:pool-single-server () + "Successive call of `jedi:start-server' with the same setup should +return the same server instance." + (jedi-testing:with-mocked-server + ;; Mock `epc:start-epc': + ((:input '("python" ("jediepcserver.py")) :output 'dummy-server)) + ;; Mock `jedi:epc--live-p': + ((:input '(nil) :output nil) ; via `jedi:start-server' + (:input '(dummy-server) :output t)) ; via `jedi:server-pool--start' + ;; Buffers to use: + (buf1 buf2) + (check-restart buf1 '("python" "jediepcserver.py") 'dummy-server) + (check-restart buf2 '("python" "jediepcserver.py") 'dummy-server))) + +(ert-deftest jedi:pool-per-buffer-server () + "Successive call of `jedi:start-server' with different setups should +return the different server instances." + (jedi-testing:with-mocked-server + ;; Mock `epc:start-epc': + ((:input '("python" ("jediepcserver.py")) :output 'dummy-server-1) + (:input '("python3" ("jediepcserver.py")) :output 'dummy-server-2)) + ;; Mock `jedi:epc--live-p': + ((:input '(nil) :output nil)) ; via `jedi:start-server' + ;; Buffers to use: + (buf1 buf2) + (check-restart buf1 '("python" "jediepcserver.py") 'dummy-server-1) + (check-restart buf2 '("python3" "jediepcserver.py") 'dummy-server-2))) + +(ert-deftest jedi:pool-restart-per-buffer-server () + "When one of the server died, only the died server must be +rebooted; not still living ones." + (jedi-testing:with-mocked-server + ;; Mock `epc:start-epc': + ((:input '("python" ("jediepcserver.py")) :output 'dummy-server-1) + (:input '("python3" ("jediepcserver.py")) :output 'dummy-server-2) + (:input '("python" ("jediepcserver.py")) :output 'dummy-server-3)) + ;; Mock `jedi:epc--live-p': + ((:input '(nil) :output nil) ; via `jedi:start-server' + (:input '(dummy-server-1) :output t) + (:input '(nil) :output nil) ; via `jedi:start-server' + (:input '(dummy-server-1) :output nil) ; server is stopped + (:input '(nil) :output nil) ; via `jedi:start-server' + (:input '(dummy-server-2) :output t) + (:input '(nil) :output nil) ; via `jedi:start-server' + (:input '(dummy-server-3) :output t)) + ;; Buffers to use: + (buf1 buf2 buf3) + (check-restart buf1 '("python" "jediepcserver.py") 'dummy-server-1) + (check-restart buf2 '("python3" "jediepcserver.py") 'dummy-server-2) + (check-restart buf3 '("python" "jediepcserver.py") 'dummy-server-1) + (mapc (lambda (b) (with-current-buffer b (setq jedi:epc nil))) + (list buf1 buf2 buf3)) + ;; Now, ``(jedi:epc--live-p dummy-server-1)`` will return nil: + (check-restart buf1 '("python" "jediepcserver.py") 'dummy-server-3) + (check-restart buf2 '("python3" "jediepcserver.py") 'dummy-server-2) + (check-restart buf3 '("python" "jediepcserver.py") 'dummy-server-3))) + +(ert-deftest jedi:pool-buffer-local-server-setting () + "Locally set `jedi:server-command' and `jedi:server-args' must be used." + (jedi-testing:with-mocked-server + ;; Mock `epc:start-epc': + ((:input '("server" ("-abc")) :output 'dummy-1) + (:input '("server" ("-xyz")) :output 'dummy-2)) + ;; Mock `jedi:epc--live-p': + ((:input '(nil) :output nil) ; via `jedi:start-server' + (:input '(dummy-1) :output t)) ; via `jedi:server-pool--start' + ;; Buffers to use: + (buf1 buf2 buf3) + ;; Set buffer local `jedi:server-command': + (with-current-buffer buf1 (set-server '("server" "-abc"))) + (with-current-buffer buf2 (set-server '("server" "-xyz"))) + (with-current-buffer buf3 (set-server '("server" "-abc"))) + ;; Check that the buffer local `jedi:server-command' is used: + (should (eq (with-current-buffer buf1 (jedi:start-server)) 'dummy-1)) + (should (eq (with-current-buffer buf2 (jedi:start-server)) 'dummy-2)) + (should (eq (with-current-buffer buf3 (jedi:start-server)) 'dummy-1)))) + +(ert-deftest jedi:pool-gc-when-no-jedi-buffers () + "GC should stop servers when there is no Jedi buffers." + (jedi-testing:with-mocked-server + ;; Mock `epc:start-epc': + ((:input '("server" ("-abc")) :output 'dummy-1) + (:input '("server" ("-xyz")) :output 'dummy-2)) + ;; Mock `jedi:epc--live-p': + ((:input '(nil) :output nil)) ; via `jedi:start-server' + ;; Buffers to use: + (buf1 buf2) + ;; Check that in this mocked environment there is no server yet: + (should (= (length (jedi:-get-servers-in-use)) 0)) + ;; Start servers: + (check-restart buf1 '("server" "-abc") 'dummy-1) + (check-restart buf2 '("server" "-xyz") 'dummy-2) + ;; GC should not stop servers in use: + (jedi:server-pool--gc) + (should (= (length (jedi:-get-servers-in-use)) 2)) + ;; GC should stop unused servers: + (mapc #'kill-buffer (list buf1 buf2)) + (mocker-let ((epc:stop-epc (x) ((:input '(dummy-1)) + (:input '(dummy-2))))) + (jedi:server-pool--gc)) + (should (= (length (jedi:-get-servers-in-use)) 0)))) + +(provide 'test-jedi) + +;; Local Variables: +;; coding: utf-8 +;; indent-tabs-mode: nil +;; End: + +;;; test-jedi.el ends here diff --git a/conf/emacs.d/test_jediepcserver.py b/conf/emacs.d/test_jediepcserver.py new file mode 100644 index 0000000..2081e08 --- /dev/null +++ b/conf/emacs.d/test_jediepcserver.py @@ -0,0 +1,27 @@ +import os +from contextlib import contextmanager + +from jediepcserver import add_virtualenv_path + + +@contextmanager +def osenv(*args, **kwds): + def putenvs(dct): + for (k, v) in dct.items(): + if v is None: + del os.environ[k] + else: + os.environ[k] = v + newenv = dict(*args, **kwds) + oldenv = dict(zip(newenv, map(os.getenv, newenv))) + try: + putenvs(newenv) + yield + finally: + putenvs(oldenv) + + +def test_add_virtualenv_path_runs_fine_in_non_virtualenv(): + # See: https://github.com/tkf/emacs-jedi/issues/3 + with osenv(VIRTUAL_ENV=None): + add_virtualenv_path() diff --git a/conf/emacs.d/tryout-jedi.el b/conf/emacs.d/tryout-jedi.el new file mode 100644 index 0000000..647ba48 --- /dev/null +++ b/conf/emacs.d/tryout-jedi.el @@ -0,0 +1,6 @@ +(require 'auto-complete) +(setq jedi:setup-keys t) +(require 'jedi) +(global-auto-complete-mode +1) +(add-hook 'python-mode-hook 'jedi:setup) +(setq jedi:complete-on-dot t)