;;; eieio-testsinvoke.el -- eieio tests for method invokation

;;;
;; Copyright (C) 2005, 2008, 2009, 2010 Eric M. Ludlam
;;
;; Author: <zappo@gnu.org>
;; RCS: $Id: eieio-test-methodinvoke.el,v 1.12 2010-04-18 21:43:18 zappo Exp $
;; Keywords: oop, lisp, tools
;;
;; 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, 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 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.
;;
;; Please send bug reports, etc. to zappo@gnu.org
;;

;;; Commentary:
;;
;; Test method invocation order.  From the common lisp reference
;; manual:
;;
;; QUOTE:
;; - All the :before methods are called, in most-specific-first
;;   order.  Their values are ignored.  An error is signaled if
;;   call-next-method is used in a :before method.
;;
;; - The most specific primary method is called. Inside the body of a
;;   primary method, call-next-method may be used to call the next
;;   most specific primary method. When that method returns, the
;;   previous primary method can execute more code, perhaps based on
;;   the returned value or values. The generic function no-next-method
;;   is invoked if call-next-method is used and there are no more
;;   applicable primary methods. The function next-method-p may be
;;   used to determine whether a next method exists. If
;;   call-next-method is not used, only the most specific primary
;;   method is called.
;;
;; - All the :after methods are called, in most-specific-last order.
;;   Their values are ignored.  An error is signaled if
;;   call-next-method is used in a :after method.
;;
;;
;; Also test behavior of `call-next-method'. From clos.org:
;;
;; QUOTE:
;; When call-next-method is called with no arguments, it passes the
;; current method's original arguments to the next method.

(defvar eieio-test-method-order-list nil
  "List of symbols stored during method invocation.")

(defun eieio-test-method-store ()
  "Store current invocation class symbol in the invocation order list."
  (let* ((keysym (aref [ :STATIC :BEFORE :PRIMARY :AFTER ]
		       (or eieio-generic-call-key 0)))
	 (c (list eieio-generic-call-methodname keysym scoped-class)))
    (setq eieio-test-method-order-list
	  (cons c eieio-test-method-order-list))))

(defun eieio-test-match (rightanswer)
  "Do a test match."
  (if (equal rightanswer eieio-test-method-order-list)
      t
    (error "eieio-test-methodinvoke.el: Test Failed!")))

(defvar eieio-test-call-next-method-arguments nil
  "List of passed to methods during execution of `call-next-method'.")

(defun eieio-test-arguments-for (class)
  "Returns arguments passed to method of CLASS during `call-next-method'."
  (cdr (assoc class eieio-test-call-next-method-arguments)))

;;; This Example was submitted by darkman:
;;
;; drkm <darkman_spam@yahoo.fr>
(defclass A () ())
(defclass AA (A) ())
(defclass AAA (AA) ())

(defmethod F :BEFORE ((p A))
  (eieio-test-method-store))
(defmethod F :BEFORE ((p AA))
  (eieio-test-method-store))
(defmethod F :BEFORE ((p AAA))
  (eieio-test-method-store))

(defmethod F ((p A))
  (eieio-test-method-store))
(defmethod F ((p AA))
  (eieio-test-method-store))

(defmethod F :AFTER ((p A))
  (eieio-test-method-store))
(defmethod F :AFTER ((p AA))
  (eieio-test-method-store))
(defmethod F :AFTER ((p AAA))
  (eieio-test-method-store))

(let ((eieio-test-method-order-list nil)
      (ans '(
	     (F :BEFORE AAA)
	     (F :BEFORE AA)
	     (F :BEFORE A)
	     ;; Not primary A method
	     (F :PRIMARY AA)
	     ;; No call-next-method in AA to get to A.
	     (F :AFTER A)
	     (F :AFTER AA)
	     (F :AFTER AAA)
	     )))
  (F (AAA nil))
  (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
  (eieio-test-match ans))

(defmethod G :BEFORE ((p A))
  (eieio-test-method-store))
(defmethod G :BEFORE ((p AAA))
  (eieio-test-method-store))

(defmethod G ((p A))
  (eieio-test-method-store))

(defmethod G :AFTER ((p A))
  (eieio-test-method-store))
(defmethod G :AFTER ((p AAA))
  (eieio-test-method-store))


(let ((eieio-test-method-order-list nil)
      (ans '(
	     (G :BEFORE AAA)
	     (G :BEFORE A)
	     ;; Not primary A method
	     (G :PRIMARY A)
	     ;; No call-next-method in AA to get to A.
	     (G :AFTER A)
	     (G :AFTER AAA)
	     )))
  (G (AAA nil))
  (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
  (eieio-test-match ans))

;;; Test Multiple Inheritance.
;;
(defclass B-base1 () ())
(defclass B-base2 () ())
(defclass B (B-base1 B-base2) ())

(defmethod F :BEFORE ((p B-base1))
  (eieio-test-method-store))

(defmethod F :BEFORE ((p B-base2))
  (eieio-test-method-store))

(defmethod F :BEFORE ((p B))
  (eieio-test-method-store))

(defmethod F ((p B))
  (eieio-test-method-store)
  (call-next-method))

(defmethod F ((p B-base1))
  (eieio-test-method-store)
  (call-next-method))

(defmethod F ((p B-base2))
  (eieio-test-method-store)
  (when (next-method-p)
    (call-next-method))
  )

(defmethod F :AFTER ((p B-base1))
  (eieio-test-method-store))

(defmethod F :AFTER ((p B-base2))
  (eieio-test-method-store))

(defmethod F :AFTER ((p B))
  (eieio-test-method-store))

(let ((eieio-test-method-order-list nil)
      (ans '(
	     (F :BEFORE B)
	     (F :BEFORE B-base1)
	     (F :BEFORE B-base2)

	     (F :PRIMARY B)
	     (F :PRIMARY B-base1)
	     (F :PRIMARY B-base2)

	     (F :AFTER B-base2)
	     (F :AFTER B-base1)
	     (F :AFTER B)
	     )))
  (F (B nil))
  (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
  ;;(message "%S" eieio-test-method-order-list)
  (eieio-test-match ans)
  )

;;; Test static invokation
;;
(defmethod H :STATIC ((class A))
  "No need to do work in here."
  'moose)

;; Both of these situations should succeed.
(H A)
(H (A nil))

;;; Return value from :PRIMARY
;;
(defmethod I :BEFORE ((a A))
  (eieio-test-method-store)
  ":before")

(defmethod I :PRIMARY ((a A))
  (eieio-test-method-store)
  ":primary")

(defmethod I :AFTER ((a A))
  (eieio-test-method-store)
  ":after")

(let ((eieio-test-method-order-list nil)
      (ans  (I (A nil))))
  (unless (string= ans ":primary")
    (error "Value %S erroneously provided in method call."
	   ans)))

;;; Multiple inheritance and the 'constructor' method.
;;
;; Constructor is a static method, so this is really testing
;; static method invocation and multiple inheritance.
;;
(defclass C-base1 () ())
(defclass C-base2 () ())
(defclass C (C-base1 C-base2) ())

(defmethod constructor :STATIC ((p C-base1) &rest args)
  (eieio-test-method-store)
  (if (next-method-p) (call-next-method))
  )

(defmethod constructor :STATIC ((p C-base2) &rest args)
  (eieio-test-method-store)
  (if (next-method-p) (call-next-method))
  )

(defmethod constructor :STATIC ((p C) &rest args)
  (eieio-test-method-store)
  (call-next-method)
  )

(let ((eieio-test-method-order-list nil)
      (ans '(
	     (constructor :STATIC C)
	     (constructor :STATIC C-base1)
	     (constructor :STATIC C-base2)
	     )))
  (C nil)
  (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
  (eieio-test-match ans)
  )

;;; Diamond Test
;;
;; For a diamond shaped inheritance structure, (call-next-method) can break.
;; As such, there are two possible orders.

(defclass D-base0 () () :method-invocation-order :depth-first)
(defclass D-base1 (D-base0) () :method-invocation-order :depth-first)
(defclass D-base2 (D-base0) () :method-invocation-order :depth-first)
(defclass D (D-base1 D-base2) () :method-invocation-order :depth-first)

(defmethod F ((p D))
  "D"
  (eieio-test-method-store)
  (call-next-method))

(defmethod F ((p D-base0))
  "D-base0"
  (eieio-test-method-store)
  ;; This should have no next
  ;; (when (next-method-p) (call-next-method))
  )

(defmethod F ((p D-base1))
  "D-base1"
  (eieio-test-method-store)
  (call-next-method))

(defmethod F ((p D-base2))
  "D-base2"
  (eieio-test-method-store)
  (when (next-method-p)
    (call-next-method))
  )

(let ((eieio-test-method-order-list nil)
      (ans '(
	     (F :PRIMARY D)
	     (F :PRIMARY D-base1)
	     ;; (F :PRIMARY D-base2)
	     (F :PRIMARY D-base0)
	     )))
  (F (D nil))
  (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
  ;(message "%S" eieio-test-method-order-list)
  (eieio-test-match ans)
  )

;;; Other invocation order

(defclass E-base0 () () :method-invocation-order :breadth-first)
(defclass E-base1 (E-base0) () :method-invocation-order :breadth-first)
(defclass E-base2 (E-base0) () :method-invocation-order :breadth-first)
(defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first)

(defmethod F ((p E))
  (eieio-test-method-store)
  (call-next-method))

(defmethod F ((p E-base0))
  (eieio-test-method-store)
  ;; This should have no next
  ;; (when (next-method-p) (call-next-method))
  )

(defmethod F ((p E-base1))
  (eieio-test-method-store)
  (call-next-method))

(defmethod F ((p E-base2))
  (eieio-test-method-store)
  (when (next-method-p)
    (call-next-method))
  )

(let ((eieio-test-method-order-list nil)
      (ans '(
	     (F :PRIMARY E)
	     (F :PRIMARY E-base1)
	     (F :PRIMARY E-base2)
	     (F :PRIMARY E-base0)
	     )))
  (F (E nil))
  (setq eieio-test-method-order-list (nreverse eieio-test-method-order-list))
  ;(message "%S" eieio-test-method-order-list)
  (eieio-test-match ans)
  )

;;; Jan's methodinvoke order w/ multiple inheritance and :after methods.
;;
(defclass Ja ()
  ())

(defmethod initialize-instance :after ((this Ja) &rest slots)
  ;(message "+Ja")
  (when (next-method-p)
    (call-next-method))
  ;(message "-Ja")
  )

(defclass Jb ()
  ())

(defmethod initialize-instance :after ((this Jb) &rest slots)
  ;(message "+Jb")
  (when (next-method-p)
    (call-next-method))
  ;(message "-Jb")
  )

(defclass Jc (Jb)
  ())

(defclass Jd (Jc Ja)
  ())

(defmethod initialize-instance ((this Jd) &rest slots)
  ;(message "+Jd")
  (when (next-method-p)
    (call-next-method))
  ;(message "-Jd")
  )

(Jd "test")

;;; call-next-method with replacement arguments across a simple class hierarchy.
;;

(defclass CNM-0 ()
  ())

(defclass CNM-1-1 (CNM-0)
  ())

(defclass CNM-1-2 (CNM-0)
  ())

(defclass CNM-2 (CNM-1-1 CNM-1-2)
  ())

(defmethod CNM-M ((this CNM-0) args)
  (push (cons 'CNM-0 (copy-sequence args))
	eieio-test-call-next-method-arguments)
  (when (next-method-p)
    (call-next-method
     this (cons 'CNM-0 args))))

(defmethod CNM-M ((this CNM-1-1) args)
  (push (cons 'CNM-1-1 (copy-sequence args))
	eieio-test-call-next-method-arguments)
  (when (next-method-p)
    (call-next-method
     this (cons 'CNM-1-1 args))))

(defmethod CNM-M ((this CNM-1-2) args)
  (push (cons 'CNM-1-2 (copy-sequence args))
	eieio-test-call-next-method-arguments)
  (when (next-method-p)
    (call-next-method)))

(defmethod CNM-M ((this CNM-2) args)
  (push (cons 'CNM-2 (copy-sequence args))
	eieio-test-call-next-method-arguments)
  (when (next-method-p)
    (call-next-method
     this (cons 'CNM-2 args))))

(let ((eieio-test-call-next-method-arguments nil))
  (CNM-M (CNM-2 "") '(INIT))
  (unless (and (equal (eieio-test-arguments-for 'CNM-0)
		      '(CNM-1-1 CNM-2 INIT))
	       (equal (eieio-test-arguments-for 'CNM-1-1)
		      '(CNM-2 INIT))
	       (equal (eieio-test-arguments-for 'CNM-1-2)
		      '(CNM-1-1 CNM-2 INIT))
	       (equal (eieio-test-arguments-for 'CNM-2)
		      '(INIT)))
    (error "eieio-test-methodinvoke.el: Test Failed!")))
