[jlisp] / jj.lisp

;;; -*-lisp-*-
;;;
;;; Pleasant Lisp interface to Java class libraries
;;;
;;; (c) 2007 Mark Wooding
;;;

;;;----- 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.

(defpackage #:jj
  (:use #:common-lisp #:java)
  (:export #:java-name #:lisp-name
	   #:java-true #:java-false #:java-null
	   #:send #:send-class #:make #:make-java-array #:java-array
	   #:field #:class-field
	   #:magic-constant-case
	   #:implementation))

(in-package #:jj)

;;;--------------------------------------------------------------------------
;;; Utilities.

(defmacro with-string-iterator ((iterator
				 string
				 &key
				 (character (gensym "CHAR"))
				 (index (gensym "INDEX"))
				 (start 0)
				 (end nil))
				&body body)
  "Evaluate BODY with ITERATOR fbound to a function which returns successive
   characters from the substring of STRING indicated by START and END.  The
   variables named by INDEX and CHARACTER are bound to the current index
   within STRING and the current character; they are modified by assignment
   by the ITERATOR function.  The ITERATOR takes one (optional) argument
   EOSP: if false (the default), ITERATOR signals an error if it reads past
   the end of the indicated substring; if true, it returns nil at
   end-of-string."
  (let ((tstring (gensym "STRING"))
	(tend (gensym "END")))
    `(let* ((,tstring ,string)
	    (,index ,start)
	    (,tend (or ,end (length ,tstring)))
	    (,character nil))
      (flet ((,iterator (&optional eosp)
	       (cond ((< ,index ,tend)
		      (setf ,character (char ,tstring ,index))
		      (incf ,index)
		      ,character)
		     (eosp nil)
		     (t (error "Unexpected end-of-string.")))))
	,@body))))

;;;--------------------------------------------------------------------------
;;; Name conversion.

(eval-when (:compile-toplevel :load-toplevel :execute)

  (defun java-name (name)
    "Returns the Java-name for NAME, as a string.  If NAME is a string, it is
     returned as-is.  If NAME is a symbol, its print-name is converted
     according to these rules.  The name is split into components separated
     by `.' characters; the components are converted independently, and
     joined, again using `.'s.

       * The final component is treated specially: if the first and last
         characters are both `*' then the `*'s are stripped off, all `-'s are
         replaced by `_'s, and other characters are emitted as-is.

       * If the first character of a component is `*' then the `*' is
         stripped and the following character is converted to upper-case.

       * A double `-' is replaced by an underscore `_'.

       * A single `-' is stripped and the following character converted to
         upper-case.

       * Other characters are converted to lower-case.

     These are the inverse of the rules for lisp-name (q.v.).

     Examples:

     Lisp name				Java name

     FOO				foo
     JAVA.AWT.*GRID-BAG-CONSTRAINTS	java.awt.GridBagConstraints
     *HORIZONTAL-SPLIT*			HORIZONTAL_SPLIT"

    (etypecase name
      (string name)
      (symbol
       (let* ((name (symbol-name name))
	      (n (length name)))
	 (with-output-to-string (out)
	   (with-string-iterator (getch name :character ch :index i :end n)
	     (tagbody
	      top
		(getch)
		(case ch
		  (#\- (go upnext))
		  (#\* (cond ((and (char= #\* (char name (1- n)))
				   (every (lambda (ch)
					    (or (char= #\- ch)
						(alphanumericp ch)))
					  (subseq name i (1- n))))
			      (map nil
				   (lambda (ch)
				     (write-char (if (char= #\- ch) #\_ ch)
						 out))
				   (subseq name i (1- n)))
			      (go done))
			     (t
			      (go upnext))))
		  (t (go main)))
	      main
		(unless (alphanumericp ch)
		  (error "Bad character in name."))
		(write-char (char-downcase ch) out)
	      next
		(unless (getch t) (go done))
		(case ch
		  (#\- (go upnext))
		  (#\. (write-char #\. out) (go top))
		  (t (go main)))
	      upnext
		(getch)
		(cond ((char= ch #\-) (write-char #\_ out))
		      ((alphanumericp ch) (write-char (char-upcase ch) out))
		      (t (error "Bad character in name.")))
		(go next)
	      done)))))))

  (defun lisp-name (name &optional (package :keyword))
    "Returns the Lisp-name for NAME, as a symbol interned in the given
     PACKAGE (defaults to keyword).  The name is split into components
     separated by `.' characters, converted independently, and joined again
     using `.'s.

       * The final component is treated specially.  If it consists entirely
         of `_', digits and upper-case letters, it is converted by replacing
         the `_'s by `-'s, and adding a `*' to the beginning and end.

       * If the first character of a component is upper-case, an `*' is
         prepended.  Other upper-case characters are preceded by `-'s.

       * Any `_' characters are replaced by `--'.

       * All letters are converted to upper-case.

     These are the inverse of the rules for java-name (q.v.)."

    (let ((n (length name)))
      (intern (with-output-to-string (out)
		(with-string-iterator
		    (getch name :character ch :index i :end n)
		  (tagbody
		   top
		     (getch)
		     (when (upper-case-p ch)
		       (write-char #\* out)
		       (let ((mid (make-array (- n i -1)
					      :element-type
					      (array-element-type name)
					      :displaced-to name
					      :displaced-index-offset
					      (1- i))))
			 (when (every (lambda (ch)
					(or (char= #\_ ch)
					    (digit-char-p ch)
					    (upper-case-p ch)))
				      mid)
			   (map nil
				(lambda (ch)
				  (write-char (if (char= #\_ ch) #\- ch)
					      out))
				mid)
			   (write-char #\* out)
			   (go done))))
		   main
		     (write-char (char-upcase ch) out)
		   next
		     (unless (getch t) (go done))
		     (cond ((char= #\_ ch)
			    (write-string "--" out)
			    (go next))
			   ((char= #\. ch)
			    (write-char #\. out)
			    (go top))
			   ((upper-case-p ch)
			    (write-char #\- out)))
		     (go main)
		   done)))
	      package))))

;;;--------------------------------------------------------------------------
;;; Dynamic method dispatch.

(defparameter *class-table* (make-hash-table :test #'equal)
  "A hash table mapping Java class names (as strings, using their Java names)
   to java-class structures. ")

(defstruct java-method
  "Structure describing a Java method or constructor.  The slots are as
   follows.

     * cache -- hash table mapping a list of argument types (as Java class
       objects) to appropriate method.  This table is populated as we go.

     * name -- Lisp symbol naming the method; :constructor for constructors.

     * min-args -- smallest number of arguments acceptable to the method.

     * max-args -- largest number of arguments acceptable.

     * overloads -- vector, indexed by (- nargs min-args), of (jmethod .
       argument-types) pairs."

  (cache (make-hash-table :test #'equal) :type hash-table)
  (name nil :type symbol)
  (min-args 0 :type fixnum)
  (max-args 0 :type fixnum)
  (overloads nil :type vector))

(defstruct java-class
  "Structure describing a Java class.  The slots are as follows.

     * name -- Lisp symbol naming the class.

     * jclass -- the Java class object.

     * methods -- hash table mapping Lisp method names to java-method
       structures.

     * constructor -- java-method structure describing the available
       constructors."

  (name nil :type symbol)
  (jclass nil :type java-object)
  (methods nil :type (or hash-table null))
  (constructor nil :type (or java-method null)))

(defconstant java-true (make-immediate-object t :boolean)
  "The Java `true' object.")
(defconstant java-false (make-immediate-object nil :boolean)
  "The Java `false' object.")
(defconstant java-null (make-immediate-object nil :ref)
  "A Java null reference.")

(defmacro define-java-method (lisp-name class method &body args)
  "Define a Lisp function LISP-NAME to call the named METHOD of CLASS on the
   given arguments.  The CLASS may be a string or symbol (it is converted by
   java-name).  The ARGS are (NAME TYPE) lists, where each TYPE is a string
   or symbol naming a Java class."
  (let ((arg-names (mapcar #'car args))
	(arg-types (mapcar (lambda (arg) (java-name (cadr arg))) args)))
  `(let ((meth (jmethod (jclass ,(java-name class))
			,(java-name method)
			,@arg-types)))
     (defun ,lisp-name (this ,@arg-names)
       (jcall meth this ,@arg-names)))))

(defun find-java-class (class)
  "Return the java-class structure for the given CLASS, which may be a
   java-class structure, a Java class object (note the difference!), a string
   naming a Java class, or a symbol giving the name in Lisp form."
  (if (java-class-p class)
      class
      (let ((jclass (jclass (if (symbolp class) (java-name class) class))))
	(or (gethash jclass *class-table*)
	    (setf (gethash jclass *class-table*)
		  (make-java-class :name (lisp-name (jclass-name jclass))
				   :jclass jclass))))))

(defun construct-method-table (methods get-params get-name)
  "Constructs the method table (as a hash-table) for a java-class object.
   The METHODS are a vector of method (or constructor) objects; GET-PARAMS is
   a function which is given a method object and returns a sequence of
   argument type objects; and GET-NAME is a function which is given a method
   object and returns the method's name, as a Lisp symbol.

   The indirection is because, inexplicably, one has to use different
   functions to extract this information from methods or constructors."

  (let ((by-name (make-hash-table))
	(output (make-hash-table)))

    ;; First pass: break the list up by name.
    (dotimes (i (length methods))
      (let* ((jmethod (aref methods i))
	     (arg-types (funcall get-params jmethod)))
	(push (list* (length arg-types)
		     jmethod
		     (coerce arg-types 'list))
	      (gethash (funcall get-name jmethod) by-name))))

    ;; Second pass: sift each name bucket by numbers of arguments.
    (maphash (lambda (name list)
	       (let* ((arg-lengths (mapcar #'car list))
		      (min-args (apply #'min arg-lengths))
		      (max-args (apply #'max arg-lengths))
		      (overloads (make-array (- max-args min-args -1)
					     :initial-element nil)))
		 (dolist (item list)
		   (pushnew (cdr item)
			    (aref overloads (- (car item) min-args))
			    :test #'equal
			    :key #'cdr))
		 (setf (gethash name output)
		       (make-java-method :min-args min-args
					 :name name
					 :max-args max-args
					 :overloads overloads))))
	     by-name)

    ;; Done!
    output))

(defun ensure-java-method-table (java-class)
  "Ensure that JAVA-CLASS has a method table, and return it."
  (or (java-class-methods java-class)
      (setf (java-class-methods java-class)
	    (construct-method-table (jclass-methods
				     (java-class-jclass java-class))
				    #'jmethod-params
				    (lambda (jmethod)
				      (lisp-name (jmethod-name jmethod)))))))

(defun ensure-java-constructor (java-class)
  "Ensure that JAVA-CLASS has a constructor object, and return it."
  (or (java-class-constructor java-class)
      (setf (java-class-constructor java-class)
	    (gethash :constructor
		     (construct-method-table (jclass-constructors
					      (java-class-jclass java-class))
					     #'jconstructor-params
					     (constantly :constructor))))))

(defun find-java-method (class name)
  "Given a CLASS (in a form acceptable to find-java-class) and a NAME (a Lisp
   symbol or Java name string), return the corresponding java-method
   structure."
  (let ((java-class (find-java-class class)))
    (gethash (if (symbolp name) name (lisp-name name))
	     (ensure-java-method-table java-class))))

(defun find-java-constructor (class)
  "Given a CLASS (in a form acceptable to find-java-class), return the
   java-method structure for its constructor."
  (ensure-java-constructor (find-java-class class)))

(defun expand-java-method (java-method)
  "Return a list-of-lists: for each overload of the method, return a list of
   its argument types, in ascending order of number of arguments."
  (let ((out nil))
    (dotimes (i (length (java-method-overloads java-method)))
      (dolist (item (cdr (aref (java-method-overloads java-method) i)))
	(push (mapcar (lambda (arg)
			(lisp-name (jclass-name arg)))
		      (cdr item))
	      out)))
    (nreverse out)))

(defun expand-java-class (java-class)
  "Return a list (NAME (:constructors . METHOD) ((METHOD-NAME . METHOD) ...))
   describing the state of a JAVA-CLASS object.  Useful for diagnostics."
  (list (java-class-name java-class)
	(cons :constructors
	      (expand-java-method (ensure-java-constructor java-class)))
	(loop for name being the hash-keys
	      of (ensure-java-method-table java-class)
	      using (hash-value method)
	      collect (cons name (expand-java-method method)))))

(defparameter *conversions*
  (let ((raw '((java.lang.*object boolean)
	       (java.lang.*number double)
	       (java.lang.*comparable double)
	       (double float java.lang.*double)
	       (float long java.lang.*float)
	       (long int java.lang.*long)
	       (int short char java.lang.*integer)
	       (short byte java.lang.*short)
	       (char java.lang.*character)
	       (boolean java.lang.*boolean))))
    (labels ((lookup (type)
	       (cdr (assoc type raw)))
	     (closure (type)
	       (delete-duplicates
		(cons type
		      (mapcan #'closure (lookup type))))))
      (mapcar (lambda (row) (mapcar (lambda (name)
				      (jclass (java-name name)))
				    (closure (car row))))
	      raw)))
  "Table encoding the various implicit conversions for primitive types, used
   occasionally to disambiguate multiple method matches.")

(defun jclass-convertible-p (from to)
  "Return whether there is an automatic conversion between FROM and TO.  This
   can be considered a partial order on types."
  (or (jclass-superclass-p to from)
      (member from (assoc to *conversions* :test #'equal)
	      :test #'equal)))

(defun argument-list-betterp (first second)
  "Return whether the type-list FIRST is `better' than SECOND, in the sense
   that there is an implicit conversion between each element of FIRST and the
   corresponding element of SECOND.  This lifts the partial order of
   jclass-better-p to lists of types."
  (cond ((endp first) (endp second))
	((endp second) nil)
	(t (and (jclass-convertible-p (car first) (car second))
		(argument-list-betterp (cdr first) (cdr second))))))

(defun get-jmethod-for-argument-types (java-method argument-types)
  "Given a JAVA-METHOD structure, return the best match overload for the
   given list of ARGUMENT-TYPES.

   An overload is considered to be a match if there is an implicit conversion
   from each actual argument type to the corresponding formal argument type.
   One matching overload is better than another if there is an implicit
   conversion from each of the former's argument types to the type of the
   corresponding argument of the latter.  If there is no unique best match
   then an error is signalled.

   In the language of the partial order defined by argument-list-betterp
   (q.v.), which we write as <=, let us denote the actual argument types by
   A, and the argument types of an overload O as simply O; then O is a match
   for A if A <= O and O is a better match than O' if O <= O'; let M be the
   set of matching overloads M = { O | A <= O }; we seek the minimum element
   of M."

  (or (gethash argument-types (java-method-cache java-method))
      (labels ((expand-arglist (args)
		 (mapcar (lambda (arg)
			   (lisp-name (jclass-name arg)))
			 args))
	       (expand-methodlist (methods)
		 (mapcar (lambda (method) (expand-arglist (cdr method)))
			 methods))
	       (consider (best next)
		 #+debug
		 (format t "*** currently: ~S~%*** considering: ~S~%"
			 (expand-methodlist best)
			 (expand-arglist (cdr next)))
		 (let ((winners (remove-if
				 (lambda (method)
				   (argument-list-betterp (cdr next)
							  (cdr method)))
				 best))
		       (include-next-p (every
					(lambda (method)
					  (not (argument-list-betterp
						(cdr method)
						(cdr next))))
					best)))
		   (if include-next-p
		       (cons next winners)
		       winners))))
	(let* ((nargs (length argument-types))
	       (min-args (java-method-min-args java-method))
	       (max-args (java-method-max-args java-method))
	       (candidates
		(and (<= min-args nargs max-args)
		     (remove-if-not (lambda (method)
				      (argument-list-betterp argument-types
							     (cdr method)))
				    (aref (java-method-overloads java-method)
					  (- nargs min-args)))))
	       (chosen (and candidates
			    (reduce #'consider (cdr candidates)
				    :initial-value (list
						    (car candidates))))))
	  #+debug
	  (progn
	    (format t "*** candidates = ~S~%"
		    (expand-methodlist candidates))
	    (format t "*** chosen = ~S~%"
		    (expand-methodlist chosen)))
	  (cond ((null chosen)
		 (error "No match found.~%  method = ~A, args = ~A"
			(java-method-name java-method)
			(expand-arglist argument-types)))
		((cdr chosen)
		 (error "Ambiguous match.~%  ~
                           method = ~A, args = ~A~%  ~
                           matches = ~A"
			(java-method-name java-method)
			(expand-arglist argument-types)
			(expand-methodlist chosen)))
		(t (setf (gethash argument-types
				  (java-method-cache java-method))
			 (caar chosen))))))))

(defun argument-type-list-from-names (names)
  "Given a list of type NAMES, return the corresponding Java class objects."
  (mapcar (lambda (name)
	    (java-class-jclass (find-java-class name)))
	  names))

(defun find-jmethod (class name arg-types)
  "Given a CLASS, a method NAME, and a list of ARG-TYPES, return the Java
   method object for the best matching overload of the method."
  (get-jmethod-for-argument-types (find-java-method class name)
				  (argument-type-list-from-names arg-types)))

(defun find-jconstructor (class arg-types)
  "Given a CLASS and a list of ARG-TYPES, return the Java constructor object
   for the best matching constructor overload."
  (get-jmethod-for-argument-types (find-java-constructor class)
				  (argument-type-list-from-names arg-types)))

(defun send (object message &rest arguments)
  "Given an OBJECT, a MESSAGE name (Lisp symbol or Java name string) and
   other ARGUMENTS, invoke the method of OBJECT named by MESSAGE which best
   matches the types of the ARGUMENTS."
  (let ((jargs (mapcar #'make-immediate-object arguments)))
    (apply #'jcall
	   (find-jmethod (jobject-class object) message
			 (mapcar (lambda (jarg) (jobject-class jarg)) jargs))
	   object
	   jargs)))

(defun send-class (class message &rest arguments)
  "Given a CLASS (anything acceptable to find-java-class), a MESSAGE name
   (Lisp symbol or Java name string) and other ARGUMENTS, invoke the static
   method of CLASS named by MESSAGE which best matches the types of the
   ARGUMENTS."
  (let ((java-class (find-java-class class))
	(jargs (mapcar #'make-immediate-object arguments)))
    (apply #'jcall
	   (find-jmethod java-class message
			 (mapcar (lambda (jarg) (jobject-class jarg)) jargs))
	   java-null
	   jargs)))

(defun make (class &rest arguments)
  "Given a CLASS (anything acceptable to find-java-class) and other
   ARGUMENTS, invoke the constructor of CLASS which best matches the types of
   the ARGUMENTS, returning the result."
  (let ((java-class (find-java-class class))
	(jargs (mapcar #'make-immediate-object arguments)))
    (apply #'jnew
	   (find-jconstructor java-class
			      (mapcar (lambda (jarg) (jobject-class jarg))
				      jargs))
	   jargs)))

;;;--------------------------------------------------------------------------
;;; Field access.

(defun field (object name)
  "Given an OBJECT and a field NAME (Lisp symbol or Java name string), return
   the value of the OBJECT's field with the given NAME.  This is a valid
   place for setf."
  (jfield (java-name name) object))

(defun (setf field) (value object name)
  "Given an OBJECT and a field NAME (Lisp symbol or Java name string), set
   the OBJECT's field with the given NAME to be VALUE."
  (jfield object name value))

(defun class-field (class name)
  "Given a CLASS and a field NAME (Lisp symbol or Java name string), return
   the value of the CLASS's static field with the given NAME.  This is a
   valid place for setf."
  (jfield (jclass (java-name class)) (java-name name)))

(defun (setf class-field) (value class name)
  "Given an CLASS and a field NAME (Lisp symbol or Java name string), set
   the CLASS's static field with the given NAME to be VALUE."
  (jfield (jclass (java-name class)) (java-name name) nil value))

;;;--------------------------------------------------------------------------
;;; Arrays.

(defun make-java-array (class items)
  "Given a CLASS (Lisp symbol or Java name string) and a sequence of ITEMS,
   return a Java array specialized for the named CLASS, containing the
   ITEMS."
  (jnew-array-from-array (if (symbolp class) (java-name class) class)
			 (if (listp items) (coerce items 'vector) items)))

(defun java-array (class &rest items)
  "Given a CLASS (Lisp symbol or Java name string) and some ITEMS, return a
   Java array specialized for the named CLASS, containing the ITEMS."
  (make-java-array class items))

;;;--------------------------------------------------------------------------
;;; Interfaces.

(defmacro implementation (class &body clauses)
  "Returns an implementation of the interface names by CLASS (Lisp symbol or
   Java name string), whose methods are defined by CLAUSES; each clause has
   the form (NAME (BVL ...) FORMS...) where NAME is the name of a method
   (Lisp symbol or Java name string), BVL is a standard bound-variable list,
   and FORMS are any Lisp forms providing the implementation of the method."
  `(jinterface-implementation
    ,(java-name class)
    ,@(loop for (name bvl . body) in clauses
	    collect (java-name name)
	    collect `(lambda ,bvl ,@body))))

;;;--------------------------------------------------------------------------
;;; Other useful hacks.

(defmacro magic-constant-case ((selector class) &body keywords)
  "SELECTOR is an expression which evaluates to a keyword; CLASS names a Java
   class (Lisp symbol or Java name string); KEYWORDS are a number of Lisp
   keyword objects.  The SELECTOR is matched against the KEYWORDS.  If a
   match is found, the keyword is converted to upper-case, `-' is converted
   to `_', and the result used as a Java static field name of the specified
   CLASS; the value of this field is returned as the value of the expression.

   Note that the class field lookups are really done at macro-expansion time,
   not at run-time."
  `(ecase ,selector
     ,@(mapcar (lambda (key)
		 `(,key ,(class-field class
				      (substitute #\_ #\-
						  (string-upcase key)))))
	       keywords)))

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