;;; sexy-java.lisp
;;;
;;; Copyright (C) 2008-2009 Alessio Stalla
;;;
;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module.  An independent module is a module which is not derived from
;;; or based on this library.  If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so.  If you do not wish to do so, delete this
;;; exception statement from your version.

(in-package :snow)

(defpackage :java-classes (:nicknames :jcl))

(defun java-class-name (java-class)
  (let* ((name (jclass-name java-class))
	 (pos (position #\. name :from-end t)))
    (if pos
	(subseq name (1+ pos))
	name)))

(defun intern-and-export (string &optional (package *package*))
  (let ((sym (intern string package)))
    (export sym package)
    sym))

(defun intern-java-class (java-class-designator &optional symbol)
  (let* ((java-class (jclass java-class-designator))
	 (interned-symbol
	  (or symbol
	      (intern-and-export (string-upcase (java-class-name java-class))
				 :java-classes)))
	 (interned-class (get interned-symbol 'java-class)))
    (flet ((do-intern-java-class (java-class)
	     (progn (setf (get interned-symbol 'java-class) java-class)
		    (values interned-symbol java-class))))
      (if interned-class
	  (if (equal interned-class java-class)
	      (values interned-symbol java-class)
	      (restart-case 
		  (error "Symbol ~A already refers to java class ~A"
			 interned-symbol (jclass-name interned-class))
		(continue ()
		  :report "Keep the previous import and ignore the new one."
		  (values interned-symbol interned-class))
		(replace ()
		  :report "Replace the previous import with the new one."
		  (do-intern-java-class java-class))))
	  (do-intern-java-class java-class)))))

(defun jmethod-parameter-types (method-or-constructor)
  (jcall (jmethod (jclass-of method-or-constructor) "getParameterTypes")
	 method-or-constructor))

(defun jclass-superclass-p/autoboxing (super class)
  (let ((boolean-type #.(jfield "java.lang.Boolean" "TYPE"))
	(boolean-class #.(jclass "java.lang.Boolean"))
	(integer-type #.(jfield "java.lang.Integer" "TYPE"))
	(integer-class #.(jclass "java.lang.Integer")))
    (or (null class)
	(jclass-superclass-p super class) ;TODO handle other primitive types
	(and (equal super boolean-type) (equal class boolean-class))
	(and (equal super boolean-class) (equal class boolean-type))
	(and (equal super integer-type) (equal class integer-class))
	(and (equal super integer-class) (equal class integer-type)))))

(defun jmethod-applicable-p (method-or-constructor arg-types)
  (let ((param-types (jmethod-parameter-types method-or-constructor)))
    (and (eql (length arg-types) (length param-types)) ;TODO handle varargs? how?
	 (every #'identity (map 'vector #'jclass-superclass-p/autoboxing
				param-types
				arg-types)))))

(defun java-class-of (obj)
  (when obj
    (jcall (jmethod "java.lang.Object" "getClass") obj)))

(defun derive-java-types (args)
  (mapcar #'java-class-of args))

(defun find-applicable-jmethod (class method-name args)
  (let ((arg-types (derive-java-types args))
	(methods (jclass-methods (jclass class))))
    (dotimes (i (length methods))
      (let ((method (aref methods i)))
	(when (and
	       (string= (jmethod-name method) method-name)
	       (jmethod-applicable-p method arg-types))
	  (return-from find-applicable-jmethod method))))))

(defun find-applicable-jconstructor (class args)
  (let ((arg-types (derive-java-types args))
	(constructors (jclass-constructors (jclass class))))
    (dotimes (i (length constructors))
      (let ((constructor (aref constructors i)))
	(when (jmethod-applicable-p constructor arg-types)
	  (return-from find-applicable-jconstructor constructor))))))

(defun canonicalize-jclass (class)
  (typecase class
    (symbol (get class 'java-class))
    (t (jclass class))))

(defun new (class &rest args)
  (let ((constr (find-applicable-jconstructor
		 (canonicalize-jclass class)
		 args)))
    (if constr
	(apply #'jnew constr args)
	(error "No applicable constructor for ~A (args: ~A, types: ~A)"
	       class args (mapcar #'jclass-name
				  (derive-java-types args))))))

(defun invoke (method object &rest args)
  (if (jinstance-of-p method "java.lang.reflect.Method")
      (apply #'jcall method object args)
      (let ((jmethod (find-applicable-jmethod
		      (java-class-of object)
		      method
		      args)))
	(if jmethod
	    (apply #'jcall jmethod object args)
	    (error "No applicable method ~A in ~A (class: ~A) for args: ~A, types: ~A"
		   method object (java-class-of object)
		   args (mapcar #'jclass-name (derive-java-types args)))))))

(defmacro jimport (class &optional symbol)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (intern-java-class ,class ,symbol)))

(define-compiler-macro new (&whole form class &rest args)
  (let ((constr
	 (when (constantp class)
	   (ignore-errors
	     (find-applicable-jconstructor
	      (canonicalize-jclass (eval class))
	      args)))))
    (if constr
	`(jnew ,constr ,@args)
	form))) ;Try delaying method resolution till runtime...

(defun jbool (obj)
  (make-immediate-object (not (not obj)) :boolean))

(defun jnot (obj)
  (make-immediate-object (not obj) :boolean))

(define-compiler-macro invoke (&whole form method object &rest args)
  (if (constantp method)
      (let ((method (eval method)))
	(cond
	  ((jinstance-of-p method "java.lang.reflect.Method")
	   `(jcall ,method ,object ,@args))
	  ((null args)
	   (if (constantp object)
	       `(jcall (jmethod ,(java-class-of (eval object)) ,method) ,object)
	       (let ((obj (gensym)))
		 `(let ((,obj ,object))
		    (jcall (jmethod (java-class-of ,obj) ,method) ,obj)))))
	  ((and (constantp object) (every #'constantp args))
	   (let* ((obj (eval object))
		  (meth (ignore-errors
			  (find-applicable-jmethod
			   (java-class-of obj)
			   method
			   (mapcar #'eval args)))))
	     (if meth
		 `(jcall ,meth ,object ,@args)
		 form))) ;Try delaying method resolution till runtime...
	  (t form)))
      form))

(defun jvector (element-type &rest args)
  (let ((arr (jnew-array (jclass element-type) (length args))))
    (loop
       :for x :in args
       :for i := 0 :then (incf i)
       :do (setf (jarray-ref arr i) x))
    arr))