;;; data-binding.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)

(defclass data-binding ()
  ((converter :initarg :converter :initform nil :accessor binding-converter)))

(defgeneric make-model (data-binding))

(defmethod make-model :around ((binding data-binding))
  "Wraps the model with a converter if one was specified for the binding"
  (let ((model (call-next-method)))
    (with-slots (converter) binding
      (cond
	((functionp converter)
	 (new "snow.binding.Converter" model converter converter))
	((consp converter)
	 (new "snow.binding.Converter" model (car converter) (cdr converter)))
	((null converter) model)
	(t (error "~A is not a valid converter" converter))))))

(defgeneric bind-widget (widget data-binding)
  (:documentation "Establishes a 'data binding' between a GUI component and a data binding target. Every time the data held by the component or by the target changes, the other one will be updated accordingly."))

;;Concrete Binding implementations

;;Cellular slot Binding
(defmodel cell-data-binding (data-binding cells::model-object)
  ((expression :initarg :expression :reader binding-expression
	       :initform (error "expression is mandatory")
	       :cell t)
   (writer :initarg writer :accessor binding-writer :initform nil :cell nil)
   (model :accessor binding-model :initform nil :cell nil)))

(defmethod initialize-instance :after ((obj cell-data-binding) &rest args)
  (declare (ignore args))
  (setf (binding-model obj)
	(make-cells-value-model obj)))

(defobserver expression ((binding cell-data-binding) new-value)
  (bwhen (it (binding-model binding))
    (invoke "valueChanged" it new-value)))

(defun make-cell-data-binding (expression &optional writer)
  (check-type writer (or null function))
  (let ((instance
	 (make-instance 'cell-data-binding :expression expression)))
    (setf (binding-writer instance) writer)
    instance))

(defun make-slot-data-binding (object slot-accessor-name)
  (make-cell-data-binding
   (eval `(c? (,slot-accessor-name ,object)))
   (compile nil `(lambda (x)
		   (setf (,slot-accessor-name ,object) x)))))

(defmethod make-model ((binding cell-data-binding))
  (binding-model binding))
  
(defun make-cells-value-model (binding)
  (new "snow.binding.AccessorBinding"
       binding
       #'binding-expression
       (lambda (value place)
	 (declare (ignore place))
	 (bwhen (it (binding-writer binding))
	   (funcall it value)))))

;;Cells-powered Variable Binding
(defmodel cell-expression ()
  ((expression :initarg :expression :accessor var
	       :initform (error "expression is mandatory")
	       :cell t)))

(defun make-var (&optional initial-value)
  (make-instance 'cell-expression :expression (c-in initial-value)))

(defun make-simple-data-binding (var)
  (make-cell-data-binding (c? (var var))
			  (lambda (x) (setf (var var) x))))

;;Bean Binding

;;JGoodies Binding presentation model
(defvar *presentation-model* nil)

(defun trigger-commit (&optional (presentation-model *presentation-model*))
  (jcall (jmethod "com.jgoodies.binding.PresentationModel"
		  "triggerCommit")
	 presentation-model))

(defun make-default-presentation-model (bean)
  (new "com.jgoodies.binding.PresentationModel" bean))

(defmacro with-presentation-model (pm &body body)
  `(let ((*presentation-model* ,pm))
     ,@body))

(defclass bean-data-binding (data-binding)
  ((object :initarg :object :reader binding-object
	   :initform (or *presentation-model* (error "object is required")))
   (property :initarg :property :reader binding-property
	     :initform (error "property is required"))
   (observed-p :initarg :observed-p :reader binding-observed-p :initform t)
   (buffered-p :initarg :buffered-p :reader binding-buffered-p :initform nil)))

(defun make-bean-data-binding (object property &rest args)
  (apply #'make-instance 'bean-data-binding :object object :property property
	 args))

(defconstant +presentation-model-class+
  (jclass "com.jgoodies.binding.PresentationModel"))

(defun presentation-model-p (obj)
  (jinstance-of-p obj +presentation-model-class+))

(defmethod make-model ((binding bean-data-binding))
  (if (presentation-model-p (binding-object binding))
      (if (binding-buffered-p binding)
	  (jcall (jmethod +presentation-model-class+
			  "getBufferedModel" "java.lang.String")
		 (binding-object binding)
		 (dashed->camelcased (binding-property binding)))
	  (jcall (jmethod +presentation-model-class+
			  "getModel" "java.lang.String")
		 (binding-object binding)
		 (dashed->camelcased (binding-property binding))))
      (jnew (jconstructor "com.jgoodies.binding.beans.PropertyAdapter"
			  "java.lang.Object" "java.lang.String"
			  "boolean")
	    (binding-object binding)
	    (dashed->camelcased (binding-property binding))
	    (jbool (binding-observed-p binding)))))

;;EL data binding
(defvar *bean-factory*
  #'(lambda (bean-name)
      (eval (read-from-string bean-name)))
  "A callback called by the EL engine with a single argument, the name of a bean to fetch from the application.")

(defclass value-model ()
  ((value-model :initarg :value-model :reader value-model)))

(defun make-property-data-binding (obj path)
  (make-instance
   'value-model
   :value-model (new "snow.binding.BeanPropertyPathBinding"
		     obj (apply #'jvector "java.lang.String" path))))
  
(defmethod make-model ((binding value-model))
  (value-model binding))

;;Default binding types
(defun default-data-binding-constructors ()
  (let ((ht (make-hash-table)))
    (setf (gethash 'simple ht) 'make-simple-data-binding)
    (setf (gethash 'var ht) 'make-simple-data-binding)
    (setf (gethash 'bean ht) 'make-bean-data-binding)
    (progn
      (setf (gethash 'cell ht) 'make-cell-data-binding)
      (setf (gethash 'slot ht) 'make-slot-data-binding))
    ht))

(defparameter *binding-constructors* (default-data-binding-constructors))

(defun make-data-binding (type &rest options)
  (apply (gethash type *binding-constructors*) options))

(defun make-el-data-binding-from-expression (el-expr package)
  (let* ((splitted-expr (split-sequence #\. el-expr))
	 (obj (let ((*package* package))
		(funcall *bean-factory* (car splitted-expr))))
	 (path (cdr splitted-expr)))
    (if path
	(if (and (presentation-model-p obj) (null (cdr path)))
	    (make-bean-data-binding obj (car path))
	    (make-property-data-binding obj path))
	(make-simple-data-binding (make-var obj)))))

(defreadtable snow:syntax
  (:merge :standard)
  (:macro-char #\$ 
    #'(lambda (stream char)
	(declare (ignore char))
	(case (peek-char nil stream)
	  (#\{
	   (read-char stream) ;;consume the #\{ character
	   `(make-el-data-binding-from-expression
	     ,(with-output-to-string (str)
	        (loop
		   :for ch := (read-char stream) :then (read-char stream)
		   :until (char= ch #\})
		   :do (write-char ch str)))
	     ,*package*)) ;;Packages are externalizable: http://www.lispworks.com/documentation/HyperSpec/Body/03_bdbb.htm
	  (#\(
	   (let ((list (read stream)))
	     (if (eq (car list) 'cells:c?)
		 `(make-data-binding 'cell ,list)
		 `(make-data-binding ',(car list) ,@(cdr list)))))
	  (t `(make-simple-data-binding ,(read stream)))))))