;;; eon.el --- object-oriented programming for emacs

;; Copyright (C) 2007  David O'Toole

;; Author: David O'Toole <dto@gnu.org>
;; Keywords: lisp, oop, extensions
;; Package-Version: 0.1
;; Version: $Id: eon.el,v 1.17 2007/09/04 02:30:50 dto Exp dto $

;; This file 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, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;; This file is not part of GNU Emacs.

;;; Commentary:

;; This file provides a facility for object-oriented programming in
;; Emacs Lisp.  The terminology is reminiscent of CLOS, but the
;; design is very different:

;; - Objects consist of named slots with arbitrary Lisp values.
;; - Methods are function-valued slots.
;; - New slots can be added whenever you want.
;; - There are no classes; instead, objects inherit data and behavior
;;   from other objects called prototypes.  These inherited
;;   slots may be overridden at any time.
;; - Automatic serialization and persistence are supported
;;   (not yet implemented)

;; This is part of a larger project called Eon:
;; http://dto.freeshell.org/notebook/Eon.html

;;; Status:

;; Currently in beta testing; a few things are not fully implemented,
;; and it is possible that the specification may change.

;;; Code:

(require 'cl)

;;; Logging

(defvar eon-log-verbose nil "When non-nil, print log messages.")

(defvar eon-log-function #'message
  "Function to use for logging Eon events.
It should interpret its arguments as `message' does.")

(defsubst eon-log (&rest args)
  "When `eon-verbose' is non-nil, log the ARGS.
The value of `eon-log-function' is called with ARGS as arguments."
  (when eon-log-verbose
    (apply eon-log-function args)))

;;;; Objects

(defstruct object
  slots ;; property list with slot names as keys. see `eon-slot-read'
	;; and `eon-slot-write'.
  id ;; optional keyword symbol uniquely identifying the object. see
     ;; `eon-resolve-id'.
  prototype ;; optional prototype object (or, its keyword identifier)
	    ;; see `eon-find-prototype' and `defprototype'.
  reference-p ;; when non-nil, this object is merely a reference to
	      ;; another. see `eon-dereference'.
  cache ;; cached data. see `eon-dereference'.
  )

(defsubst eon-dereference (object)
  "If OBJECT is a reference, return its referent.
Otherwise, return OBJECT.  See `eon-resolve-id'.

Unless you are hacking eon itself, don't use this function in
Lisp programs.  Instead, use `eon-slot-read' and
`eon-slot-write' by writing
 
   (@ object slot)
or
   (setf (@ object slot) value)"
  (if (object-reference-p object)
      ;;
      ;; it's a reference to another object. see if the referent is cached
      (or (object-cache object)
	  ;;
	  ;; not yet cached. attempt to look up the actual object
	  (let ((id (object-id object)))
	    (if id
		;; 
		;; resolve the id and cache the resultant object
		(setf (object-cache object) (eon-resolve-id id))
	      (eon-log "Cannot follow reference with no ID and no CACHE."))))
    ;;
    ;; not a reference; return the object itself
    object))

;;;; Identifiers

;; Some objects are identified by a keyword symbol. These identifiers
;; may be "resolved" to retrieve the object itself.  Such "identified
;; objects" can be computed, retrieved, downloaded, etc. on demand,
;; depending on how `eon-resolver-functions' is set.

;; Temporary objects and objects which are components of other objects
;; will usually have no associated identifiers. But many important
;; types of objects will be identified: for example, prototypes and
;; stores.

(defvar eon-cache (make-hash-table :test 'equal)
  "Hash table mapping identifier symbols to the identified objects.")

(defun eon-clear-cache ()
  "Delete all entries from the eon object cache.  Don't do this."
  (interactive)
  (eon-log "Clearing eon object cache.")
  (setf eon-cache (make-hash-table :test 'equal)))

(defvar eon-resolver-functions ()
  "List of functions to use in resolving IDs.
Each function should accept a string, and return an object
corresponding to that string (or nil, of none can be found.")

(defun eon-resolve-id (id)
  "Obtain the object named ID.
The `eon-cache' is searched first, in which case the object is
returned.  Otherwise, try the functions in
`eon-resolver-functions' until one returns an object."
  (eon-log "Resolving id %S" id)
  (or (or (gethash id eon-cache)
	  (puthash id (let ((string (symbol-name id)))
			(some (lambda (f)
				(funcall f string))
			      eon-resolver-functions))
		   eon-cache))
      (eon-log "Could not resolve identifier %S" id)))
	       
;;;; Prototypes

;; Prototype objects serve as templates for creating new objects.
;; Each prototype object has a keyword identifier. A new object
;; inherits its slot values from its prototype. See also
;; `eon-slot-read.'

(defmacro defprototype (prototype-id documentation slot-descriptors)
  "Create a new prototype.

PROTOTYPE-ID is the id of the prototype you are defining.  This
should be a keyword symbol.  DOCUMENTATION is a documentation
string for the prototype.  Elements of the list SLOT-DESCRIPTORS
are property lists with the following keys:

 :slot-name      Keyword symbol identifying the slot.
 :default-value  Default value for the slot.
 :documentation  Documentation string for the slot."
  (let ((slots
	 ;;
	 ;; extract default slot values from slot descriptors
	 (append (mapcan (lambda (slot-descriptor)
			   (destructuring-bind
			       (slot-name (&key default-value &allow-other-keys))
			       slot-descriptor
			     (when default-value (list slot-name default-value))))
			 slot-descriptors)
		 (list :slot-descriptors slot-descriptors
		       :documentation documentation
		       :clone 'eon-default-clone-method))))
    `(puthash ,prototype-id
	      (make-object :slots ',slots
			   :id ',prototype-id
			   :prototype ',prototype-id)
	      eon-cache)))

(defsubst eon-find-prototype (object)
  "Return the prototype of the OBJECT, if any."
  (let ((p (object-prototype object)))
    (if (keywordp p)
	;;
	;; look up the prototype and cache the object here
	(setf (object-prototype object) (eon-resolve-id p))
      ;;
      ;; just return the prototype object
      p)))

(defun eon-default-clone-method (object)
  "Clone the OBJECT.

When a new object is cloned from a prototype, it inherits the
prototype's slot values.  The values are not copied; instead the
new object starts with no slots, and the slot lookup procedure
looks in the prototype for a value when it cannot be found in the
object itself (see also `eon-slot-read'.)"
  (let ((clone (make-object :prototype (object-prototype object))))
    (when (@ clone :initialize)
      (>> clone :initialize))
    clone))

(defun eon-clone-prototype (prototype-id)
  "Clone the prototype whose id is PROTOTYPE-ID."
  (let ((prototype (gethash prototype-id eon-cache)))
    (if prototype
	(>> prototype :clone)
      (error "No such prototype %S" prototype-id))))

;;;; Slots

;; The slot collection is just a property list. So the slot names are
;; ordinary keyword symbols, and lookup is accomplished with
;; plist-get. If a slot value is not present, the prototype is also
;; checked for a value; this is how objects can inherit data and
;; behavior from their prototypes. See `eon-slot-read' below. When
;; you set the value of any slot, the prototype's value is effectively
;; overridden. See `eon-slot-write' below.

;; Efficiency note: According to the Emacs Lisp Manual, hash tables
;; are actually slower than property lists when you only have a few
;; tens of items. (If you have an object with more than 30 or so
;; slots, you're probably doing something wrong.)

(defun eon-slot-read (object slot)
  "Retrieve from OBJECT the value of SLOT.
If the slot has no value, then the object's prototype is also checked."
  (let* ((o (eon-dereference object))
	 (tail (plist-member (object-slots o) slot)))
    (if tail
	;;
	;; the slot has a value in this object. return the value
	(second tail)
      ;;
      ;; otherwise, check the prototype for a value
      (let ((p (eon-find-prototype o)))
	(when p
	  (plist-get (object-slots p) slot))))))
	
(defun eon-slot-write (object slot value)
  "Set OBJECT's SLOT to VALUE.
The new value overrides any value inherited from the prototype."
  (let ((o (eon-dereference object)))
    (setf (object-slots o)
	  (plist-put (object-slots o) slot value))))

(defalias '@ 'eon-slot-read)
(defsetf eon-slot-read eon-slot-write)
(defsetf @ eon-slot-write) ;; Now you can write (setf (@ object :slot) value)

;;;; Methods

(defmacro defmethod
 (method method-args prototype-id documentation &rest method-body)
  "Define a new method.

METHOD is a keyword symbol naming the method.  METHOD-ARGS is a
list of symbols that will become bound to the corresponding
keyword-argument values in the body of the method.  PROTOTYPE-ID
is the id of the prototype that you are defining a method for.
DOCUMENTATION is a description of the method.

The forms in METHOD-BODY are executed when the method is
invoked.  The hidden argument `self' may be referred to as needed
in method bodies.  See also `with-slots'."
    ;;
    ;; build the components of the defun
    (let ((method-defun-symbol (intern (concat "eon:method"
					       (symbol-name prototype-id)
					       (symbol-name method)))))
      ;;
      ;; make sure the prototype exists
      `(let ((prototype (gethash ,prototype-id eon-cache)))
	 (when (null prototype)
	   (error "Cannot define method %S for nonexistent prototype %S"
		  method ,prototype-id))
	 ;;
	 ;; define the method's function
	 (defun* ,method-defun-symbol (self &key ,@method-args)
	   ,documentation
	   ,@method-body)
	 (setf (@ prototype ,method) ',method-defun-symbol)
	 ;;
	 ;; add new slot-descriptor for this method to the prototype
	 (setf (@ prototype :slot-descriptors)
	       (cons '(,method (:documentation ,documentation))
		     ;;
		     ;; don't create duplicate entries
		     (remove-if (lambda (d)
				  (eq ,method (first d)))
				(@ prototype :slot-descriptors)))))))

(defmacro with-slots (slots &rest body)
  "With SLOTS in local scope, execute the forms in BODY.

Do not use this outside of a `defmethod'.  We use
`symbol-macrolet' to create fake local variables.  References to
the symbols in SLOTS are transformed into slot reads/writes as
appropriate."
  (declare (indent 1))
  `(symbol-macrolet
       ,(mapcar (lambda (slot)
		  (list slot
			`(@ self
			    ,(intern (concat
				      ":"
				      (symbol-name slot))))))
		slots)
     ,@body))

(defun object-invoke-method (object method &rest args)
  "Send OBJECT the message METHOD with arguments ARGS.
ARGS is a property list of slot names and values to be passed."
  (let* ((method-spec (eon-slot-read object method))
	 (handler (if (and (symbolp method-spec) (fboundp method-spec))
		      (symbol-function method-spec)
		    method-spec)))
    (if handler
	(apply handler object args)
      (error "No method for %S" method))))

(defalias '>> 'object-invoke-method)

;;;; Font-locking support

(defvar object-font-lock-keywords '(("(\\(@\\>\\)" (1 font-lock-type-face))
				    ("(\\(>>\\>\\)" (1 font-lock-type-face))
				    ("(\\(defprototype\\>\\)" (1 font-lock-keyword-face))
				    ("(\\(defprotocol\\>\\)" (1 font-lock-keyword-face))))

(defun object-do-font-lock ()
  "Highlight the keywords used in object-oriented eon programming."
  (font-lock-add-keywords nil object-font-lock-keywords))

(add-hook 'emacs-lisp-mode-hook #'object-do-font-lock)

;;;; A short example

'(progn

   ;; You can use C-x C-e to evaluate the example step-by-step.

   (eon-clear-cache)

   (defprototype :ticker
     "This is a simple counter."
     ((:meaningless (:documentation "Self-explanatory." :default-value "Boo!"))
      (:counter (:documentation "How many times I have ticked." :default-value 0))))
	
   (defmethod :tick () :ticker
     "Increment the value of the counter."
     (with-slots (meaningless counter)
       (incf counter)
       (setf meaningless "I have ticked.")))
   
   (defmethod :print () :ticker
     "Print the value of the counter."
     (with-slots (counter)
       (message "%S" counter)))
   
   (defmethod :shout (string) :ticker
     "Print the STRING as an exclamation, and store the original string."
     (with-slots (meaningless)
       (message "%s!" (upcase string))
       (setf meaningless string)))
   
   (defmethod :tick-and-shout (string) :ticker
     (>> self :tick)
     (>> self :shout :string string))

   ;; now for the action...
   
   (defvar o)
   (setf o (eon-clone-prototype :ticker))
   (>> o :print)
   (>> o :tick)
   (>> o :print)
   (>> o :shout :string "chthulhu fthagn")
   (>> o :tick-and-shout :string "oh my it's a twister")
   (>> o :print)
   )

(provide 'eon)
;;; eon.el ends here