added rudel (obby and other colab framework for emacs)

1 files changed, 305 insertions, 0 deletions

diff --git a/emacs.d/lisp/rudel/rudel-backend.el b/emacs.d/lisp/rudel/rudel-backend.el
new file mode 100644
index 0000000..79cfef6
--- /dev/null
+++ b/emacs.d/lisp/rudel/rudel-backend.el
@@ -0,0 +1,305 @@
+;;; rudel-backend.el --- A generic backend management mechanism for Rudel
+;;
+;; Copyright (C) 2009 Jan Moringen
+;;
+;; Author: Jan Moringen <scymtym@users.sourceforge.net>
+;; Keywords: Rudel, backend, factory
+;; X-RCS: $Id:$
+;;
+;; This file is part of Rudel.
+;;
+;; Rudel 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.
+;;
+;; Rudel 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 Rudel. If not, see <http://www.gnu.org/licenses>.
+
+
+;;; Commentary:
+;;
+;; This file contains a generic mechanism that handles registration,
+;; query and instantiation of Rudel backends for any number of
+;; functional categories.
+;;
+;; The class and collaboration design is as follows: for each
+;; category, which is identified by a symbol, there is a factory
+;; object (an instance of `rudel-backend-factory') that is responsible
+;; for creating backend objects of the category.  Examples of
+;; categories are 'transport', 'protocol' and 'session-initiation'.
+;; In addition to creating backend object, factories also allow
+;; querying backends based on desired capabilities and load backend
+;; implementations only when required.
+
+
+;;; History:
+;;
+;; 0.1 - Initial revision
+
+
+;;; Code:
+;;
+
+(eval-when-compile
+  (require 'cl))
+
+(require 'eieio)
+
+
+;;; Class rudel-backend
+;;
+
+(defclass rudel-backend ()
+  ((version      :initarg  :version
+		 :type     list
+		 :documentation
+		 "A list of the form (MAJOR MINOR [MICRO
+WHATEVER*]) describing the version of the backend.")
+   (capabilities :initarg  :capabilities
+		 :type     list
+		 :initform nil
+		 :documentation
+		 "A list of symbols, or lists whose car is a
+symbol, that each describe one capability of the backend."))
+  "Base class for backend classes."
+  :abstract t)
+
+(defmethod rudel-capable-of-p ((this rudel-backend) capability)
+  "Return t if the backend THIS is capable of CAPABILITY."
+  (with-slots (capabilities) this
+    (member capability capabilities)))
+
+
+;;; Class rudel-backend-factory
+;;
+
+(defclass rudel-backend-factory ()
+  ((backends  :initarg   :backends
+	      :type       hash-table
+	      :documentation
+	      "Mapping of symbolic names to classes (prior to
+instantiation) or objects (after instantiation) for all backends
+known to the factory object.")
+   (factories :type       hash-table
+	      :allocation :class
+	      :documentation
+	      "Mapping of backend categories to responsible
+factory objects."))
+  "Factory class that holds an object for each known backend
+category. Objects manage backend implementation for one backend
+category each.")
+(oset-default rudel-backend-factory factories
+	      (make-hash-table :test #'eq))
+
+(defmethod initialize-instance ((this rudel-backend-factory) &rest slots)
+  "Initialize slots of THIS with SLOTS."
+  (when (next-method-p)
+    (call-next-method))
+  (oset this :backends (make-hash-table :test #'eq)))
+
+;;;###autoload
+(defmethod rudel-get-factory :static ((this rudel-backend-factory)
+				      category)
+  "Return the factory responsible for CATEGORY.
+If there is no responsible factory, create one and return it."
+  (with-slots (factories) this
+    (or (gethash category factories)
+	(puthash category (rudel-backend-factory category) factories)))
+  )
+
+;;;###autoload
+(defmethod rudel-add-backend ((this rudel-backend-factory)
+			      name class &optional replace)
+  "Add factory class CLASS with name NAME to THIS.
+if REPLACE is non-nil, replace a registered implementation of the
+same name."
+  (with-slots (backends) this
+    (when (or (not (gethash name backends))
+	      replace)
+      (puthash name class backends))))
+
+(defmethod rudel-get-backend ((this rudel-backend-factory) name)
+  "Return backend object for name NAME or nil if there is none.
+The returned backend is of the form (NAME . OBJECT).
+
+Backends are loaded, if necessary."
+  ;; Load all available backends
+  (rudel-load-backends this)
+
+  ;; Find the backend and return it.
+  (with-slots (backends) this
+    (let ((backend (gethash name backends)))
+      (when backend
+	(cons name backend))))
+  )
+
+(defmethod rudel-all-backends ((this rudel-backend-factory))
+  "Return a list of all backends registered with THIS.
+Each list element is of the form (NAME . CLASS-OR-OBJECT)."
+  (let ((backend-list))
+    (with-slots (backends) this
+      (maphash (lambda (name class)
+		 (push (cons name class) backend-list))
+	       backends))
+    backend-list)
+  )
+
+(defmethod rudel-suitable-backends ((this rudel-backend-factory) predicate)
+  "Return a list of backends which satisfy PREDICATE.
+Each list element is of the form (NAME . OBJECT).
+Backends are loaded, if necessary."
+  ;; Load all available backends
+  (rudel-load-backends this)
+
+  ;; Retrieve and return all backends, possibly filtering the list
+  ;; using PREDICATE.
+  (if predicate
+      (remove-if-not
+       (lambda (cell)
+	 (and (object-p (cdr cell))
+	      (funcall predicate (cdr cell))))
+       (rudel-all-backends this))
+    (rudel-all-backends this))
+  )
+
+(defmethod rudel-load-backends ((this rudel-backend-factory))
+  "Load backends in THIS factory if necessary.
+Loading errors are not reported explicitly, but can be detected
+by checking for backends that still are classes rather than
+objects."
+  ;; Map lambda that loads unloaded backends over all backends. Store
+  ;; objects back after loading.
+  (with-slots (backends) this
+    (maphash
+     (lambda (name class)
+       (unless (object-p class)
+	 (condition-case error
+	     (puthash name (make-instance
+			    class (symbol-name name)) backends)
+	   (error (display-warning
+		   '(rudel backend)
+		   (format "Could not load backend `%s': %s"
+			   name
+			   (error-message-string error))
+		   :warning)))))
+	 backends))
+  )
+
+
+;;; High-level frontend functions
+;;
+
+(defsubst rudel-backend-cons-p (cell)
+  "Check whether CELL is a cons of a backend name and object."
+  (and (consp cell)
+       (symbolp (car cell))
+       (object-p (cdr cell))))
+
+;;;###autoload
+(defun rudel-backend-get (category name)
+  "A shortcut for getting backend NAME of category CATEGORY.
+The returned backend is of the form (NAME . OBJECT)."
+  (rudel-get-backend (rudel-backend-get-factory category) name))
+
+;;;###autoload
+(defun rudel-backend-get-factory (category)
+  "A shortcut for getting the factory object for CATEGORY."
+  (rudel-get-factory rudel-backend-factory category))
+
+(defun rudel-backend-suitable-backends (category predicate)
+  "Return backends from category CATEGORY that satisfy PREDICATE.
+Each list element is of the form (NAME . OBJECT)."
+  (rudel-suitable-backends
+   (rudel-backend-get-factory category)
+   predicate))
+
+(defun rudel-backend-choose (category &optional predicate)
+  "Choose a backend from CATEGORY satisfying PREDICATE automatically or by asking the user.
+The returned backend is of the form (NAME . CLASS-OR-OBJECT)."
+  (let ((backends (rudel-backend-suitable-backends
+		   category predicate)))
+    (unless backends
+      (error "No backends available"))
+
+    (if (= (length backends) 1)
+	;; If there is only one backend, we can choose that one right
+	;; away displaying a message to avoid confusing the user.
+	(let ((backend (nth 0 backends)))
+	  (message "Using backend `%s'" (symbol-name (car backend)))
+	  (sit-for 0.5)
+	  backend)
+
+      ;; When we have more than one backend, we have to ask the user,
+      ;; which one she wants.
+      (require 'rudel-interactive)
+      (rudel-read-backend backends nil 'object)))
+  )
+
+
+;;; User interaction functions
+;;
+
+(defun rudel-backend-dump (&optional load)
+  "Create display information about backends in a buffer.
+If LOAD is non-nil, load all backends before display. This makes
+available information available for the backends"
+  (interactive "p")
+  (save-excursion
+    ;; Setup a new buffer.
+    (set-buffer (get-buffer-create "*Rudel Backends*"))
+    (erase-buffer)
+    (set-window-buffer nil (current-buffer))
+    (maphash
+     (lambda (category factory)
+       ;; Load backends if requested.
+       (unless (zerop load)
+	 (rudel-load-backends factory))
+
+       ;; Insert header for this category.
+       (insert (propertize
+		(format "Category %s\n" category)
+		'face 'bold))
+       (insert (apply #'format
+		      "  %-20s %-6s %-7s %s\n"
+		      (mapcar
+		       (lambda (header)
+			 (propertize header 'face 'italic))
+		       '("name" "loaded" "version" "capabilities"))))
+
+       ;; Insert all backends provided by this factory.
+       (dolist (backend (rudel-all-backends factory))
+	 (insert (format "  %-20s %-6s %-7s (%s)\n"
+			 (propertize
+			  (symbol-name (car backend))
+			  'face 'font-lock-type-face)
+			 (propertize
+			  (prin1-to-string (object-p (cdr backend)))
+			  'face 'font-lock-variable-name-face)
+			 (propertize
+			  (if (object-p (cdr backend))
+			      (mapconcat #'prin1-to-string
+					 (oref (cdr backend) :version)
+					 ".")
+			    "?")
+			  'face 'font-lock-constant-face)
+			 (propertize
+			  (if (object-p (cdr backend))
+			      (mapconcat #'prin1-to-string
+					 (oref (cdr backend) :capabilities)
+					 " ")
+			    "?")
+			  'face 'font-lock-constant-face))))
+
+       ;; One empty line between backend categories.
+       (insert "\n"))
+     (oref rudel-backend-factory factories)))
+  )
+
+(provide 'rudel-backend)
+;;; rudel-backend.el ends here