;;;;
;;;; AspectL
;;;;
;;;; Copyright (c) 2005, 2006 Pascal Costanza
;;;;
;;;; Permission is hereby granted, free of charge, to any person
;;;; obtaining a copy of this software and associated documentation
;;;; files (the "Software"), to deal in the Software without
;;;; restriction, including without limitation the rights to use,
;;;; copy, modify, merge, publish, distribute, sublicense, and/or
;;;; sell copies of the Software, and to permit persons to whom the
;;;; Software is furnished to do so, subject to the following
;;;; conditions:
;;;;
;;;; The above copyright notice and this permission notice shall be
;;;; included in all copies or substantial portions of the Software.
;;;;
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;;; OTHER DEALINGS IN THE SOFTWARE.
;;;;

(in-package #:aspectl)

(defclass pointcut ()
  ((name :accessor pointcut-name
         :initform nil)
   (join-points :accessor pointcut-join-points
                :initform nil)
   (aspect-weavers :accessor pointcut-aspect-weavers
                   :initform nil)
   (active-advices :accessor pointcut-active-advices
                   :initform (make-hash-table :test #'equal)))
  (:documentation
   "A generic pointcut is a container for join points and aspect weavers."))

(defvar *pointcuts* (make-hash-table :test #'eq))

(defgeneric find-pointcut (name &optional errorp)
  (:method ((name symbol) &optional (errorp t))
   "Find a pointcut in the global environment."
   (or (gethash name *pointcuts*)
       (when errorp (error "~S is not the name of a pointcut." name)))))

(defgeneric (setf find-pointcut) (pointcut name)
  (:method ((pointcut pointcut) (name symbol))
   (setf (pointcut-name pointcut) name)
   (setf (gethash name *pointcuts*) pointcut)))

(defgeneric ensure-pointcut (name)
  (:method ((name symbol))
   "Ensure that a pointcut of the given name exists."
   (or (find-pointcut name nil)
       (setf (find-pointcut name) (make-instance 'pointcut)))))

(defclass join-point ()
  ((name :accessor join-point-name :initarg :name)
   (args :accessor join-point-args :initarg :args)))

(defclass aspect-weaver ()
  ((name :accessor aspect-weaver-name :initarg :name)
   (function :accessor aspect-weaver-function :initarg :function))
  (:documentation
   "An aspect weaver has a name and a weaver function. The weaver function can be applied
    to a join point in order to install a method, and must return that (single!) installed
    method. The weaver function is passed the aspect weaver object itself, the join point
    object, and the join point args as &rest parameters."))

(defgeneric activate (pointcut aspect-weaver join-point)
  (:method ((pointcut pointcut) 
	    (aspect-weaver aspect-weaver)
	    (join-point join-point))
   "Applies an aspect weaver to a join point and records the result,
            an installed method, as an active advice."
   (push (apply (aspect-weaver-function aspect-weaver)
                aspect-weaver join-point
                (join-point-args join-point))
         (gethash (cons aspect-weaver join-point)
                  (pointcut-active-advices pointcut)))))

(defun deactivate* (pointcut thing key)
  (declare (function key))
  (maphash (lambda (cons methods)
             (when (eq (funcall key cons) thing)
               (dolist (method methods)
                 (remove-method (method-generic-function method) method))
               (remhash cons (pointcut-active-advices pointcut))))
           (pointcut-active-advices pointcut)))

(defgeneric deactivate (pointcut aspect-weaver-or-join-point)
  (:method ((pointcut pointcut)
	    (aspect-weaver aspect-weaver))
   "Removes active advices from their generic functions,
            identified by an aspect weaver."
   (deactivate* pointcut aspect-weaver #'car))
  (:method ((pointcut pointcut)
	    (join-point join-point))
   "Removes active advices from their generic functions,
            identified by a join point."
   (deactivate* pointcut join-point #'cdr)))

(defgeneric remove-join-point (pointcut join-point)
  (:method ((pointcut pointcut)
	    (join-point join-point))
   "Deactivate advices generated by a join point and remove it."
   (deactivate pointcut join-point)
   (removef (pointcut-join-points pointcut) join-point)))

(defgeneric find-join-point (pointcut name)
  (:method ((pointcut pointcut)
	    (name symbol))
   "Find a join point in a pointcut."
   (find name (pointcut-join-points pointcut)
         :key #'join-point-name)))

(defgeneric add-join-point (pointcut join-point)
  (:method ((pointcut pointcut)
	    (join-point join-point))
   "Activate all aspect weavers on a join point and record it.
            If another join point with the same name already exists, remove it beforehand."
   (when-let (old-join-point (find-join-point pointcut (join-point-name join-point)))
     (remove-join-point pointcut old-join-point))
   (dolist (aspect-weaver (pointcut-aspect-weavers pointcut))
     (activate pointcut aspect-weaver join-point))
   (push join-point (pointcut-join-points pointcut))))

(defgeneric remove-aspect-weaver (pointcut aspect-weaver)
  (:method ((pointcut pointcut)
	    (aspect-weaver aspect-weaver))
   "Deactivate advices generated by an aspect-weaver and remove it."
   (deactivate pointcut aspect-weaver)
   (removef (pointcut-aspect-weavers pointcut) aspect-weaver)))

(defgeneric find-aspect-weaver (pointcut name)
  (:method ((pointcut pointcut)
	    (name symbol))
   "Find an aspect weaver in a pointcut."
   (find name (pointcut-aspect-weavers pointcut)
         :key #'aspect-weaver-name)))

(defgeneric add-aspect-weaver (pointcut aspect-weaver)
  (:method ((pointcut pointcut)
	    (aspect-weaver aspect-weaver))
   "Activate an aspect weaver on each join point and record it.
            If another aspect weaver with the same name already exists, remove it beforehand."
   (when-let (old-weaver (find-aspect-weaver pointcut (aspect-weaver-name aspect-weaver)))
     (remove-aspect-weaver pointcut old-weaver))
   (dolist (join-point (pointcut-join-points pointcut))
     (activate pointcut aspect-weaver join-point))
   (push aspect-weaver (pointcut-aspect-weavers pointcut))))
  
(defmacro define-pointcut (name)
  "Define a pointcut. This is also implicitly performed by define-join-point
   and define-aspect-weaver."
  `(ensure-pointcut ',name))

(defmacro define-join-point (pointcut
                             join-point-name
                             &rest args)
  "Define a join point. The args are passed as a &rest parameter to
   the aspect weavers applied to this join point."
  `(add-join-point
    (ensure-pointcut ',pointcut)
    (make-instance 'join-point
                   :name ',join-point-name
                   :args (list ,@args))))

(defmacro define-aspect-weaver (pointcut 
                                aspect-weaver-name 
                                (&rest args) 
                                &body body)
  "Define an aspect weaver, with args as the lambda list and body as the body
   of the aspect weaver function."
  `(add-aspect-weaver
    (ensure-pointcut ',pointcut)
    (make-instance 'aspect-weaver
                   :name ',aspect-weaver-name
                   :function (lambda ,args ,@body))))