;;; -*-lisp-*-
;;;
;;; $Id$
;;;
;;; Useful bits of MOP hacking
;;;
;;; (c) 2006 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 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, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

;;;--------------------------------------------------------------------------
;;; Packages.

(defpackage #:mdw.mop
  (:use #:common-lisp #:mdw.base #+cmu #:pcl)
  (:export #:compatible-class
	   #:copy-instance #:copy-instance-using-class
	   #:initargs-for-effective-slot #:make-effective-slot
	   #:filtered-slot-class-mixin
	     #:filtered-direct-slot-definition
	     #:filtered-effective-slot-definition
	   #:predicate-class-mixin
	   #:abstract-class-mixin #:instantiate-abstract-class
	   #:singleton-class-mixin
	   #:mdw-class #:abstract-class #:singleton-class
	   #:print-object-with-slots))

(in-package #:mdw.mop)

;;;--------------------------------------------------------------------------
;;; Basic stuff.

(defclass compatible-class (standard-class)
  ()
  (:documentation
   "A class which can be be freely used in class heirarchies with
    standard-class and other subclasses of compatible-class.  This saves a
    bunch of annoying messing about with `validate-superclass'."))

(defmethod validate-superclass
    ((sub compatible-class) (super compatible-class))
  t)

(defmethod validate-superclass
    ((sub compatible-class) (super standard-class))
  (eq (class-of super) (find-class 'standard-class)))

(defmethod validate-superclass
    ((sub standard-class) (super compatible-class))
  (eq (class-of sub) (find-class 'standard-class)))

;;;--------------------------------------------------------------------------
;;; Copying instances.

(defgeneric copy-instance-using-class (class object &rest initargs)
  (:documentation
   "Does the donkey-work behind copy-instance."))

(defmethod copy-instance-using-class
    ((class standard-class) object &rest initargs)
  (let ((new (apply #'allocate-instance class initargs)))
    (dolist (slot (class-slots class))
      (setf (slot-value-using-class class new slot)
	    (slot-value-using-class class object slot)))
    (apply #'shared-initialize new nil initargs)
    new))

(defun copy-instance (object &rest initargs)
  "Make a copy of OBJECT, modifying it by setting slots as requested by
   INITARGS."
  (apply #'copy-instance-using-class (class-of object) object initargs))

;;;--------------------------------------------------------------------------
;;; Utilities for messing with slot options.

(defgeneric initargs-for-effective-slot (class direct-slots)
  (:documentation
   "Missing functionality from the MOP: given a class and its direct slots
    definitions, construct and return the proposed initializer list for
    constructing the effective-slot."))

(defmethod initargs-for-effective-slot
    ((class standard-class) direct-slots)
  "Extract the effective slot options as required."
  ;;
  ;; This is taken from the Closette implementation, but it seems to work!
  (let ((init-slot (find-if-not #'null direct-slots
				:key #'slot-definition-initfunction)))
    (list :name (slot-definition-name (car direct-slots))
	  :initform (and init-slot
			 (slot-definition-initform init-slot))
	  :initfunction (and init-slot
			     (slot-definition-initfunction init-slot))
	  :initargs (remove-duplicates
		     (apply #'append
			    (mapcar #'slot-definition-initargs
				    direct-slots)))
	  :allocation (slot-definition-allocation (car direct-slots)))))

(defun make-effective-slot (class initargs)
  "Construct an effectie slot definition for a slot on the class, given the
   required arguments."
  (apply #'make-instance
	 (apply #'effective-slot-definition-class class initargs)
	 initargs))

(let ((stdslot (find-class 'standard-direct-slot-definition)))
  (defmethod compute-effective-slot-definition
      ((class compatible-class) slot-name direct-slots)
    "Construct an effective slot definition for the given slot."
    ;;
    ;; Ideally we don't want to mess with a slot if it's entirely handled by
    ;; the implementation.  This check seems to work OK.
    (if (every (lambda (slot)
		 (member (class-of slot)
			 (class-precedence-list stdslot)))
	       direct-slots)
	(call-next-method)
	(make-effective-slot class
			     (initargs-for-effective-slot class
							  direct-slots)))))

;;;--------------------------------------------------------------------------
;;; Filterered slots.

(defclass filtered-slot-class-mixin (compatible-class)
  ()
  (:documentation
   "A filtered slot interposes a filter on any attempt to write to the slot.
    The filter is given the proposed new value, and should return the actual
    new value.  Specify the filter with a  `:filter SYMBOL' slot option.
    (Yes, I know that using functions would be nicer, but the MOP makes
    that surprisingly difficult.)"))

(defclass filtered-direct-slot-definition
    (standard-direct-slot-definition)
  ((filter :initarg :filter :reader slot-definition-filter)))

(defgeneric slot-definition-filter (slot)
  (:method ((slot slot-definition)) nil))

(defclass filtered-effective-slot-definition
    (standard-effective-slot-definition)
  ((filter :initarg :filter :accessor slot-definition-filter)))

(defmethod direct-slot-definition-class
    ((class filtered-slot-class-mixin)
     &key (filter nil filterp) &allow-other-keys)
  (declare (ignore filter))
  (if filterp
      (find-class 'filtered-direct-slot-definition)
      (call-next-method)))

(defmethod effective-slot-definition-class
    ((class filtered-slot-class-mixin)
     &key (filter nil filterp) &allow-other-keys)
  (declare (ignore filter))
  (if filterp
      (find-class 'filtered-effective-slot-definition)
      (call-next-method)))

(defmethod initialize-instance :after
    ((slot filtered-direct-slot-definition) &key)
  (with-slots (filter) slot
    (when (and (consp filter)
	       (or (eq (car filter) 'function)
		   (eq (car filter) 'quote))
	       (symbolp (cadr filter))
	       (null (cddr filter)))
      (setf filter (cadr filter)))))

(defmethod initargs-for-effective-slot
    ((class filtered-slot-class-mixin) direct-slots)
  (let ((filter-slot (find-if #'slot-definition-filter direct-slots)))
    (append (and filter-slot
		 (list :filter (slot-definition-filter filter-slot)))
	    (call-next-method))))

(defmethod (setf slot-value-using-class)
    (value
     (class filtered-slot-class-mixin)
     (object standard-object)
     (slot filtered-effective-slot-definition))
  (call-next-method (funcall (slot-definition-filter slot) value)
		    class object slot))

;;;--------------------------------------------------------------------------
;;; Predicates.

(defclass predicate-class-mixin (compatible-class)
  ((predicates :type list :initarg :predicate :initform nil
	       :documentation "Predicate generic function to create."))
  (:documentation
   "Class which can automatically generate a predicate generic function.
    Adds the `:predicate' class option, which takes a single symbol argument
    FUNC.  If specified, and non-nil, a generic function FUNC with one
    argument will be defined (if it doesn't already exist) with a default
    method returning nil, and a method added specialized on this class
    returning a non-nil value."))

(defmethod shared-initialize :after
    ((class predicate-class-mixin) slot-names &key)
  (declare (ignore slot-names))
  (with-slots (predicates) class
    (dolist (predicate predicates)
      (let ((lambda-list '(thing)))
	(let ((gf (if (fboundp predicate)
		      (fdefinition predicate)
		      (let ((gf (ensure-generic-function
				 predicate :lambda-list lambda-list)))
			(add-method gf (make-instance
					'standard-method
					:specializers (list (find-class 't))
					:lambda-list lambda-list
					:function (constantly nil)))))))
	  (add-method gf (make-instance 'standard-method
					:specializers (list class)
					:lambda-list lambda-list
					:function (constantly t))))))))

;;;--------------------------------------------------------------------------
;;; Abstract classes.

(defclass abstract-class-mixin (compatible-class)
  ()
  (:documentation
   "Confusingly enough, a concrete metaclass for abstract classes.  This
    class has a `make-instance' implementation which signals an error."))

(define-condition instantiate-abstract-class (error)
  ((class :reader instantiate-abstract-class-class :initarg :class
	  :documentation "The class someone attempted to instantiate."))
  (:report (lambda (cond stream)
	     (format stream "Cannot instantiate abstract class ~A."
		     (class-name (instantiate-abstract-class-class cond)))))
  (:documentation
   "Reports an attempt to instantiate an abstract class."))

(defmethod make-instance ((class abstract-class-mixin) &rest whatever)
  "Signals an error.  The caller is a naughty boy."
  (declare (ignore whatever))
  (error 'instantiate-abstract-class :class class))

;;;--------------------------------------------------------------------------
;;; Singleton classes.

(defclass singleton-class-mixin (compatible-class)
  ((instance :initform nil :type (or null standard-object)))
  (:documentation
   "A class which has only one instance.  All calls to `make-instance' return
    the same object."))

(defmethod allocate-instance ((class singleton-class-mixin) &key)
  "If the class already has an instance, return it; otherwise allocate one,
   store it away, and return that."
  (with-slots (instance) class
    (or instance
	(setf instance (call-next-method)))))

;;;--------------------------------------------------------------------------
;;; Useful classes.

(defclass mdw-class (filtered-slot-class-mixin
		     predicate-class-mixin
		     compatible-class)
  ()
  (:documentation
   "A generally useful metaclass with handy features.  If I've done the
    hacking right, there shouldn't be a significant cost to using this
    metaclass for all your classes if you don't use any of its fancy
    features."))

(defclass abstract-class (mdw-class abstract-class-mixin) ())
(defclass singleton-class (mdw-class singleton-class-mixin) ())

;;;--------------------------------------------------------------------------
;;; Printing things.

(defun print-object-with-slots (obj stream)
  "Prints objects in a pleasant way.  Not too clever about circularity."
  (let ((class (pcl:class-of obj))
        (magic (cons 'magic nil)))
    (print-unreadable-object (obj stream)
      (pprint-logical-block
          (stream
           (mapcan (lambda (slot)
                     (list (or (car (slot-definition-initargs slot))
                               (slot-definition-name slot))
                           (if (slot-boundp-using-class class obj slot)
                               (slot-value-using-class class obj slot)
                               magic)))
                   (pcl:class-slots class)))
        (format stream "~S" (pcl:class-name class))
        (let ((sep nil))
          (loop
            (pprint-exit-if-list-exhausted)
            (if sep
                (format stream " ~_")
                (progn (format stream " ~@_~:I") (setf sep t)))
            (let ((name (pprint-pop))
                  (value (pprint-pop)))
              (format stream "~S ~@_~:[~W~;#<unbound>~*~]"
                      name (eq value magic) value))))))))

;;;----- That's all, folks --------------------------------------------------