path: root/emacs.d/lisp/rudel/rudel-backend.el

;;; 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