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

(defvar *dynamic-environment* nil)
(defvar *event* nil "Dynamic variable holding an object that represents the event currently being handled.")

(defmacro with-snow-dynamic-environment (&body body)
  (with-unique-names (package-var terminal-io-var
		      standard-input-var standard-output-var error-output-var
		      backing-bean-var presentation-model-var)
    `(if *dynamic-environment*
	 (with-dynamic-environment (*dynamic-environment*)
	   ,@body)
	 (let ((,package-var *package*)
	       (,terminal-io-var *terminal-io*)
	       (,standard-input-var *standard-input*)
	       (,standard-output-var *standard-output*)
	       (,error-output-var *error-output*)
	       (,backing-bean-var *backing-bean*)
	       (,presentation-model-var *presentation-model*)) ;;Etc...
       (dynamic-wind
	(let ((*package* ,package-var)
	      (*debugger-hook* *graphical-debugger-hook*)
	      (*terminal-io* ,terminal-io-var)
	      (*standard-input* ,standard-input-var)
	      (*standard-output* ,standard-output-var)
	      (*error-output* ,error-output-var)
	      (*backing-bean* ,backing-bean-var)
	      (*presentation-model* ,presentation-model-var))
	  (proceed
	   (let ((*dynamic-environment* (capture-dynamic-environment)))
	     (with-dynamic-environment (*dynamic-environment*)
	       ,@body)))))))))

(defmacro lambda/dynamic-environment (args &body body)
  (with-unique-names (dynamic-environment)
    `(with-snow-dynamic-environment
       (let ((,dynamic-environment *dynamic-environment*))
	 (lambda ,args (with-dynamic-environment (,dynamic-environment)
	      (let ((*dynamic-environment* ,dynamic-environment))
		,@body)))))))

(defmacro with-gui ((&rest args) &body body)
  (declare (ignore args))
  `(call-in-gui-thread
    (lambda/dynamic-environment () ,@body)))

(defun dashed->camelcased (string-designator)
  "Transforms a name (string designator) from the Lisp naming convention of separating multiple words with dashes to the Java camelCase convention."
  (let ((str (string string-designator))
	(last-was-dash-p nil))
    (with-output-to-string (out)
      (map nil (lambda (ch)
		 (if (char= #\- ch)
		     (setq last-was-dash-p t)
		     (if last-was-dash-p
			 (progn
			   (princ (char-upcase ch) out)
			   (setq last-was-dash-p nil))
			 (princ (char-downcase ch) out))))
	   str))))

(defgeneric widget-property (widget name)
  (:documentation "Retrieves the value of a widget's property. Widget properties names are dependent on the GUI backend and cannot be used portably across different GUI libraries."))
(defgeneric (setf widget-property) (value widget name)
  (:documentation "Sets the value of a widget's property. Widget properties names are dependent on the GUI backend and cannot be used portably across different GUI libraries."))

(defmethod (setf widget-property) (value widget name)
  (setf (jproperty-value widget (if (stringp name)
				    name
				    (dashed->camelcased name)))
	value))

(defmethod widget-property (widget name)
  (jproperty-value widget (if (stringp name)
			      name
			      (dashed->camelcased name))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun map-keys (fn arglist &key (filter-if (constantly nil)))
  "Maps _fn_ over _arglist_, returning a new list containing the results of applying _fn_ on each key-value pair, in the same order. As an exception to this, when _fn_ returns a value V such that (funcall _filter-if_ V) is true, the value is not included in the returned list."
  (when arglist
    (let (key result)
      (loop
	 :for x :in arglist :for even := t :then (not even)
	 :if even :do (setq key x)
	 :else :do (let ((value (funcall fn key x)))
		     (unless (funcall filter-if value)
		       (push value result))))
      (nreverse result)))))

(defmacro set-widget-properties (widget &rest props)
  "Convenience macro to set a number of widget properties in bulk."
  (with-unique-names (widget-var)
    `(let ((,widget-var ,widget))
       ,@(map-keys (lambda (key value)
		     `(setf (widget-property ,widget-var ,key) ,value))
		   props))))

(defgeneric bind-widget (widget binding)
  (:documentation "Connects a widget to a data binding. The framework automatically chooses which property of the widget to connect."))

(defun setup-container-widget (self &key (layout-manager :default) &allow-other-keys)
  "Common setup for all container widgets."
  (setf (layout-manager self)
	(apply #'make-layout-manager self
	       (ensure-list (or layout-manager :default)))))

(defun generate-default-children-processing-code (id children &optional env)
  "Can be used inside a macro defining a container widget to generate the code to process its body, adding children to it."
  (let ((code
	 (loop
	    :for form :in children
	    :collect (if (listp form)
			 (cond 
			   ((get (car form) 'widget-p) form)
			   (t `(let ((*parent* nil)) ,form)))
			 form))))
    `((let ((*parent* self))
	,@code))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun common-widget-args ()
    '(id layout binding (enabled-p t) (visible-p t) location size border font
      background foreground
      on-mouse-click on-mouse-press on-mouse-release
      on-mouse-enter on-mouse-exit
      on-mouse-drag on-mouse-move))
  (defun common-container-widget-args ()
    '((layout-manager :default)))
  (defun common-widget-args-declarations ()
    (let ((arg-names (mapcar (lambda (x) (if (atom x) x (car x)))
			     (common-widget-args))))
    `((declare (ignorable ,@arg-names)))))
  (defun filter-arglist (args filtered-keys)
    "Eliminates :key value pairs in args where key is a member of filtered-keys. Returns a new list without the removed pairs."
    (loop
       :for key :in args :by #'cddr
       :for value :in (cdr args) by #'cddr
       :when (not (member key filtered-keys))
       :collect key :and
       :collect value))
  (defun filter-unevaluated-widget-args (args)
    (filter-arglist args '(:id))))

(defun setup-widget (self &key layout binding (enabled-p t) (visible-p t)
		     location size border font background foreground
		     ;;mouse event handling
		     on-mouse-click on-mouse-press on-mouse-release
		     on-mouse-enter on-mouse-exit
		     on-mouse-drag on-mouse-move
		     &allow-other-keys)
  "Performs the common setup of any widget."
  (macrolet ((wrap-event-callback (fn) ;;Pay attention to double evaluation
	       `(when ,fn
		  (lambda/dynamic-environment (evt)
		    (let ((*event* evt))
		      (funcall ,fn))))))
    (when *parent* (add-child self *parent* layout))
    (setf (widget-enabled-p self) enabled-p)
    (setf (widget-visible-p self) visible-p)
    (when (or on-mouse-click on-mouse-press on-mouse-release
	      on-mouse-enter on-mouse-exit
	      on-mouse-drag on-mouse-move)
      (setup-mouse-listeners
       self
       (wrap-event-callback on-mouse-click)
       (wrap-event-callback on-mouse-press)
       (wrap-event-callback on-mouse-release)
       (wrap-event-callback on-mouse-enter)
       (wrap-event-callback on-mouse-exit)
       (wrap-event-callback on-mouse-drag)
       (wrap-event-callback on-mouse-move)))
    (when location (setf (widget-location self) location))
    (when binding (bind-widget self binding))
    (when size (setf (widget-size self) size))
    (when font (setf (widget-font self) font))
    (when background
      (if (keywordp background)
	  (setf (widget-background self) (color background))
	  (setf (widget-background self) background)))
    (when foreground
      (if (keywordp foreground)
	  (setf (widget-foreground self) (color foreground))
	  (setf (widget-foreground self) foreground)))
    (when border
      (setf (widget-border self) border))))

#+emacs (put 'define-widget-macro 'lisp-indent-function 3)
#+emacs (put 'define-widget 'lisp-indent-function 3)
#+emacs (put 'define-container-widget 'lisp-indent-function 3)

(defvar *backing-bean* nil)

(defun maybe-inject-widget (widget property-name)
  (when *backing-bean*
    ;;sub-optimal: should ignore property not found, but propagate other errors
    (ignore-errors (setf (jproperty-value *backing-bean* property-name)
			 widget))))

(defmacro define-widget-macro (name arglist constructor &body body)
  "Defines a macro that expands to code constructing and initializing a widget, and setting up the environment expected by Snow. <arglist> must contain exactly one occurrence of the symbol snow:&common-widget-args, which define-widget-macro will replace with the common part of the argument list of every widget macro."
  ;;Todo check that arglist contains exactly one &common-widget-args
  (with-unique-names (env)
    `(progn
       (defmacro ,name ,(append (splice-into (common-widget-args)
					     '&common-widget-args
					     arglist)
				`(&environment ,env))
	 ,@(common-widget-args-declarations)
	 `(let ((self ,,constructor))
	    ;;The lexical variable self is always bound to the current widget.
	    ,(if id ;;id is one of the common args
		(if (sys:variable-information id ,env) ;;id is lexically bound
		    `(progn
		       (setf ,id self)
		       (maybe-inject-widget self ,(dashed->camelcased id))
		       ,,@body)
		    `(let ((,id self))
		       (maybe-inject-widget self ,(dashed->camelcased id))
		       ,,@body))
		`(progn ,,@body))
	    self))
       (setf (get ',name 'widget-p) t))))

(define-widget-macro with-widget
    ((widget &rest args &key &common-widget-args) &body body)
    `(dont-add ,widget)
  `(progn
     ,@(generate-default-children-processing-code id body)
     (setup-widget self ,@(filter-unevaluated-widget-args args))))

(define-widget-macro child
    (widget &rest args &key &common-widget-args)
    `(dont-add ,widget)
  `(setup-widget self ,@(filter-unevaluated-widget-args args)))

(defmacro define-widget (name keys constructor &body body)
  "Convenience macro for defining a widget."
  (with-unique-names (args)
    `(define-widget-macro ,name
	 (&rest ,args &key &common-widget-args ,@keys)
	 `(funcall (lambda (&rest args) ;;to evaluate args only once
		     (let ((self (apply (function ,',constructor) args)))
		       (apply #'setup-widget self args)
		       self))
		   ,@(filter-unevaluated-widget-args ,args))
       `(progn
;TODO - declare keys ignorable to reduce the number of warnings.
;	    (declare (ignorable ,@(mapcar (lambda (k)
;					    (if (atom k) k (car k)))
;					  keys)))
	  ,,@body))))

(defmacro define-container-widget (name keys constructor &body body)
  "Convenience macro for defining a container widget."
  (with-unique-names (args macro-body)
    `(define-widget-macro ,name
	 ((&rest ,args &key &common-widget-args id layout-manager ,@keys)
	  &body ,macro-body)
	 `(funcall (lambda (&rest args) ;;to evaluate args only once
		     (let ((self (apply (function ,',constructor) args)))
		       (apply #'setup-widget self args)
		       (apply #'setup-container-widget self args)
		       self))
		   ;;remove id because it must not be evaluated
		   ,@(filter-unevaluated-widget-args ,args))
       `(progn
	  ,(progn ,@body) ;Bug in ABCL? ,,@body fails when body is NIL: Wrong number of arguments for CONS - it generates (cons (append (generate...) (apply...)))
	  ,@(generate-default-children-processing-code id ,macro-body)))))

(defmacro auto-add-children (&body body)
  `(let ((*parent* self))
     ,@body))

(defmacro dont-add (&body body)
  `(let ((*parent* nil))
     ,@body))
