;; events.scm: DOM events exports and implementation for SDOM
;; Copyright (C) 2004 Julian Graham

;; SDOM 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.
;;
;; SDOM 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 SDOM; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

(define-module (sdom events)
  #:use-module (srfi srfi-1)
  #:use-module (sdom core)
  #:export     (sdom:event?
		sdom:events-enabled
		sdom:dispatch-event-internal
		sdom:has-event-listener?
		sdom:add-event-listener!
		sdom:remove-event-listener!
		sdom:get-event-property
		event-groups

		lookup-event

		sdom:dom-key-location-standard
		sdom:dom-key-location-left
		sdom:dom-key-location-right
		sdom:dom-key-location-numpad

		event-groups
		
		event-annotations
		event-whole-annotation
		event-annotation
		event-annotate!))

(sdom:register-feature! "Events" "3.0")
(sdom:register-feature! "UIEvents" "3.0")
(sdom:register-feature! "TextEvents" "3.0")
(sdom:register-feature! "MouseEvents" "3.0")
(sdom:register-feature! "KeyboardEvents" "3.0")
(sdom:register-feature! "MutationEvents" "3.0")
(sdom:register-feature! "MutationNameEvents" "3.0")

(define sdom:dom-key-location-standard	0)
(define sdom:dom-key-location-left	1)
(define sdom:dom-key-location-right	2)
(define sdom:dom-key-location-numpad	3)

(define sdom:event-exception-code-unspecified-event-type-err	0)
(define sdom:event-exception-code-dispatch-request-err		1)

(define sdom:event-phase-capturing	1)
(define sdom:event-phase-at-target	2)
(define sdom:event-phase-bubbling	3)

(define initial-event-groups-hash-size 16)

(define event-groups (make-hash-table initial-event-groups-hash-size))

;; Alright, so what do events look like?  Well, let's model 'em on SXML
;; S-exprs.  How about something like this:
;;
;; (*EVENT* event-type target (@ (sdom:prop val) (sdom:prop val)))
;;
;; Event listeners are stored in a hash of hashes keyed on nodes.  The values
;; in this hash are lists of event handlers categorized by groups, like so:
;;
;; (("default" (event-type capture #<procedure f()>)))

(define event-whole-annotation
  (lambda (event prop) 
    (let ((r (find (lambda (x) (eq? (car x) prop)) 
		   (event-annotations event)))) 
      (if r r '()))))
(define event-annotation 
  (lambda (event prop) 
    (let ((r (event-whole-annotation event prop)))
      (if (not (null? r)) (cadr r) '()))))
(define event-annotations 
  (lambda (event) (if (> (length event) 3) (cdadr (cddr event)) '())))
(define event-annotate! 
  (lambda (event annt) 
    (let ((r (event-whole-annotation event (car annt))))
      (if (not (null? r))
	  (set-car! (cdr r) (cadr annt))
	  (if (> (length event) 3) 
	      (append! (cadddr event) `(,annt))
	      (append! event `((@ ,annt))))))))

(define sdom:event-structure
  `(sdom:event 
    (@ (! sdom:type (,(lambda (x) (cadr x))) ())
       (! sdom:target (,(lambda (x) (caddr x))) ())
       (! sdom:current-target () ())
       (! sdom:event-phase () ())
       (! sdom:bubbles () ())
       (! sdom:cancelable (,(lambda (x) #f)) ())
       (! sdom:time-stamp () (,(lambda (e d) (current-time))))
       (! sdom:namespace-uri () ()))
    (* (sdom:event-load ,#f (,sdom:node-type-document
			     ,sdom:node-type-element))
       (sdom:event-unload ,#f (,sdom:node-type-document
			       ,sdom:node-type-element))
       (sdom:event-abort ,#t (,sdom:node-type-element))
       (sdom:event-error ,#t (,sdom:node-type-element))
       (sdom:event-select ,#t (,sdom:node-type-element))
       (sdom:event-change ,#t (,sdom:node-type-element))
       (sdom:event-submit ,#t (,sdom:node-type-element))
       (sdom:event-reset ,#t (,sdom:node-type-element))
       (sdom:event-resize ,#t (,sdom:node-type-document
			       ,sdom:node-type-element))
       (sdom:event-scroll ,#t (,sdom:node-type-document
			       ,sdom:node-type-element)))
    (sdom:custom-event)
    (sdom:ui-event 
     (@ (! sdom:view () (,(lambda (e d) (list-ref d 0)))
	(! sdom:detail () (,(lambda (e d) (list-ref d 1))))))
     (* (sdom:event-dom-activate ,#t (,sdom:node-type-element))
	(sdom:event-dom-focus-in ,#t (,sdom:node-type-element))
	(sdom:event-dom-focus-out ,#t (,sdom:node-type-element)))
     (sdom:text-event 
      (@ (! sdom:data () (,(lambda (e d) (list-ref d 2)))))
      (* (sdom:event-text-input ,#t (,sdom:node-type-element))))
     (sdom:mouse-event 
      (@ (! sdom:screen-x () (,(lambda (e d) (list-ref d 2))))
	 (! sdom:screen-y () (,(lambda (e d) (list-ref d 3))))
	 (! sdom:client-x () (,(lambda (e d) (list-ref d 4))))
	 (! sdom:client-y () (,(lambda (e d) (list-ref d 5))))
	 (! sdom:ctrl-key () (,(lambda (e d) (list-ref d 6))))
	 (! sdom:shift-key () (,(lambda (e d) (list-ref d 7))))
	 (! sdom:alt-key () (,(lambda (e d) (list-ref d 8))))
	 (! sdom:meta-key () (,(lambda (e d) (list-ref d 9))))
	 (! sdom:button () (,(lambda (e d) (list-ref d 10))))
	 (! sdom:related-target () (,(lambda (e d) (list-ref d 11)))))
      (* (sdom:event-click ,#t (,sdom:node-type-element))
	 (sdom:event-mousedown ,#t (,sdom:node-type-element))
	 (sdom:event-mouseup ,#t (,sdom:node-type-element))
	 (sdom:event-mouseover ,#t (,sdom:node-type-element))
	 (sdom:event-mousemove ,#t (,sdom:node-type-element))
	 (sdom:event-mouseout ,#t (,sdom:node-type-element))))
     (sdom:keyboard-event 
      (@ (! sdom:key-identifier () (,(lambda (e d) (list-ref d 2))))
	 (! sdom:key-location () (,(lambda (e d) (list-ref d 3))))
	 (! sdom:ctrl-key () (,(lambda (e d) (list-ref d 4))))
	 (! sdom:shift-key () (,(lambda (e d) (list-ref d 5))))
	 (! sdom:alt-key () (,(lambda (e d) (list-ref d 6))))
	 (! sdom:meta-key () (,(lambda (e d) (list-ref d 7)))))
      (* (sdom:event-keydown ,#t (,sdom:node-type-element))
	 (sdom:event-keyup ,#t (,sdom:node-type-element)))))
    (sdom:mutation-event 
     (@ (! sdom:related-node () (,(lambda (e d) (list-ref d 0))))
	(! sdom:prev-value () (,(lambda (e d) (list-ref d 1))))
	(! sdom:new-value () (,(lambda (e d) (list-ref d 2))))
	(! sdom:attr-name () (,(lambda (e d) (list-ref d 3))))
	(! sdom:attr-change () (,(lambda (e d) (list-ref d 4)))))
     (* (sdom:event-dom-subtree-modified 
	 ,#t 
	 (,sdom:node-type-document
	  ,sdom:node-type-document-fragment
	  ,sdom:node-type-element
	  ,sdom:node-type-attr))
	(sdom:event-dom-node-inserted 
	 ,#t 
	 (,sdom:node-type-element
	  ,sdom:node-type-attr
	  ,sdom:node-type-text
	  ,sdom:node-type-comment
	  ,sdom:node-type-cdata-section
	  ,sdom:node-type-document-type
	  ,sdom:node-type-entity-reference
	  ,sdom:node-type-processing-instruction))
	(sdom:event-dom-node-removed 
	 ,#t
	 (,sdom:node-type-element
	  ,sdom:node-type-attr
	  ,sdom:node-type-text
	  ,sdom:node-type-comment
	  ,sdom:node-type-cdata-section
	  ,sdom:node-type-document-type
	  ,sdom:node-type-entity-reference
	  ,sdom:node-type-processing-instruction))
	(sdom:event-dom-node-removed-from-document 
	 ,#f 
	 (,sdom:node-type-element
	  ,sdom:node-type-attr
	  ,sdom:node-type-text
	  ,sdom:node-type-comment
	  ,sdom:node-type-cdata-section
	  ,sdom:node-type-document-type
	  ,sdom:node-type-entity-reference
	  ,sdom:node-type-processing-instruction))
	(sdom:event-dom-node-inserted-into-document 
	 ,#f 
	 (,sdom:node-type-element
	  ,sdom:node-type-attr
	  ,sdom:node-type-text
	  ,sdom:node-type-comment
	  ,sdom:node-type-cdata-section
	  ,sdom:node-type-document-type
	  ,sdom:node-type-entity-reference
	  ,sdom:node-type-processing-instruction))
	(sdom:event-dom-attr-modified ,#t (,sdom:node-type-element))
	(sdom:event-dom-character-data-modified 
	 ,#t 
	 (,sdom:node-type-text
	  ,sdom:node-type-comment
	  ,sdom:node-type-cdata-section
	  ,sdom:node-type-processing-instruction)))
     (sdom:mutation-name-event
      (@ (! sdom:prev-namespace-uri () (,(lambda (e d) (list-ref d 5))))
	 (! sdom:prev-node-name () (,(lambda (e d) (list-ref d 6)))))
      (* (sdom:event-dom-element-name-changed ,#t (,sdom:node-type-element))
	 (sdom:event-dom-attribute-name-changed 
	  ,#t (,sdom:node-type-element)))))))

(define sdom:event?
  (lambda (node)
    (cond ((not (list? node)) #f)
	  ((not (eq? (car node) '*EVENT*)) #f)
	  (else #t))))

(define get-event-groups
  (lambda (node) 
    (let* ((d (if (eqv? (sdom:node-type node) sdom:node-type-document) 
		  node (sdom:get-dom-property node "sdom:owner-document")))
	   (dg (hashq-ref event-groups d)))
      (if (not dg) '() (let ((eg (hashq-ref dg node))) (if dg dg '()))))))

(define get-event-handlers
  (lambda (node group) 
    (let ((g (find (lambda (x) (equal? (car x) group)) 
		   (get-event-groups node))))
      (if g (cdar g) '()))))
      
(define lookup-event
  (lambda (event-sym)
    (letrec 
	((f (lambda (lst inh) 
	      (let ((a (let ((x (find (lambda (y) (eq? (car y) '@)) 
				      (cdr lst))))
			 (if x (append inh (cdr x)) inh)))
		    (m (let ((e (find (lambda (x) (eq? (car x) '*)) 
				      (cdr lst))))
			 (if e (find (lambda (x) (eq? (car x) event-sym)) 
				     (cdr e)) #f))))
		(if (not m)
		    (let ((c (filter (lambda (x) (not (or (eq? (car x) '@)
							  (eq? (car x) '*))))
				     (cdr lst))))
		      (if c (let ((r (find (lambda (x) (not (null? x)))
					   (map (lambda (y) (f y a)) c))))
			      (if r r '()))))
		    (append m a))))))
      (f sdom:event-structure '()))))

(define inherits-from? (lambda (event-sym interface-sym) ()))

(define sdom:get-event-property 
  (lambda (event prop)
    (if (not (sdom:event? event))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (if (not (string? prop))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))

    (let ((proto (find (lambda (x) (eq? (if (eq? (car x) '!) (cadr x) (car x))
					(string->symbol prop)))
		       (cdddr (lookup-event (cadr event))))))
      (if (not proto)
	  (throw 'sdom:exception sdom:exception-code-not-found-err)
	  (if (null? (if (eq? (car proto) '!) (caddr proto) (cadr proto)))
	      (event-annotation event (string->symbol prop))
	      (apply (if (eq? (car proto) '!) (caaddr proto) (caadr proto))
		     `(,event)))))))

(define sdom:has-event-listener? 
  (lambda (node event-type . namespace-uri) 
    (if (not (sdom:node? node))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (let* ((groups (hashq-ref event-groups node))
	   (handler (find (lambda (x) (find (lambda (y) 
					      (eq? (car y) event-type))
					    (cdr x)))
			  groups)))
      (if handler #t #f))))      

(define get-ancestors 
  (lambda (node)
    (if (null? node)
	(list)
	(let ((p (sdom:get-dom-property 
		  node (if (eq? (car node) '@) 
			   "sdom:owner-element" 
			   "sdom:parent-node"))))
	  (if (and p (not (null? p))) 
	      (cons p (get-ancestors p))
	      (list))))))

(define sdom:will-trigger? 
  (lambda (node event-type . namespace-uri) 
    (if (find (lambda (x)
		(sdom:has-event-listener? x event-type namespace-uri))
	      (get-ancestors node))
	#t #f)))

(define sdom:add-event-listener!
  (lambda (node event group handler capture . uri)
    (let ((new-listener `(,event ,capture ,handler))
	  (groups (hashq-ref event-groups node)))
      (if (not groups)
	  (hashq-set! event-groups node `((,group ,new-listener)))
	  (let ((grp (find (lambda (x) (equal? (car x) group))
			   groups)))
	    (if (not grp)
		(append! groups `((,group ,new-listener)))
		(let ((listener (find (lambda (x) (and (eq? (car x) event)
						       (eq? (cadr x) capture)))
				      (cdr grp))))
		  (if (not listener)
		      (append! grp `(,new-listener))
		      (set-car! (cddr listener) handler)))))))))

(define sdom:remove-event-listener!
  (lambda (node event listener capture)
    (let ((groups (hashq-ref event-groups node))
	  (pred (lambda (x) (and (eq? (car x) event)
				 (eq? (cadr x) capture)))))
      (if groups
	  (begin 
	    (for-each (lambda (x) 
			(for-each (lambda (y) 
				    (if (pred y) (delq! y x))) (cdr x))
			(if (= (length x) 1) (delq! x groups)))
		      groups)
	    (if (= (length (car groups)) 1)
		(if (> (length groups) 1)
		    (hashq-set! event-groups node (cdr groups))
		    (hashq-remove! event-groups node))))))))

;; Dispatch should do some checking to make sure there's enough data...

(define sdom:dispatch-event-internal
  (lambda (target event . data)
    (if (not (sdom:node? target))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    (if (not (symbol? event))
	(throw 'sdom:exception sdom:exception-code-type-mismatch-err))
    
    ;; (display "DISPATCH-EVENT: ") (display (symbol->string event)) (newline)
    (let* ((e `(*EVENT* ,event ,target))
	   (a (append `(,target) (get-ancestors target)))
	   (proto (lookup-event event)))
      
      (event-annotate! e `(sdom:time-stamp ,(current-time)))
      (event-annotate! e `(sdom:current-target ,(car a)))

      (if (or (null? proto)
	      (not (memv (sdom:node-type target) (caddr proto))))
	  (throw 'sdom:exception sdom:exception-code-type-mismatch-err))
      (for-each (lambda (x) 
		  (let ((s (if (eq? (car x) '!) (cdr x) x)))
		    (if (not (null? (caddr s))) 
			(event-annotate! 
			 e `(,(car s) ,(apply (caaddr s) e data '()))))))
		(cdddr proto))
      ;; (display proto) (newline)


      (let* ((can-apply? (lambda (x p)
			   (and (eq? (car x) event)
				(or (eqv? p sdom:event-phase-at-target)
				    (and (eqv? p sdom:event-phase-capturing)
					 (cadr x))
				    (and (eqv? p sdom:event-phase-bubbling)
					 (cadr proto)
					 (not (cadr x)))))))
	     (f (lambda (node p)
		 (event-annotate! e `(sdom:current-phase ,p))
		 (let ((groups (hashq-ref event-groups node)))
		   (if groups 
		       (for-each (lambda (x)
				   (for-each (lambda (y)
					       (if (can-apply? y p)
						   (apply (caddr y) `(,e))))
					     x))
				 (map (lambda (x) (cdr x)) groups)))))))

	;; (display "CAPTURE: ") (display (symbol->string event)) (newline)
	(event-annotate! e `(sdom:event-phase ,sdom:event-phase-capturing))
	(for-each (lambda (x) (f x sdom:event-phase-capturing)) a)
	
	;; (display "TARGET: ") (display (symbol->string event)) (newline)
	(event-annotate! e `(sdom:event-phase ,sdom:event-phase-at-target))
	(f (caddr e) sdom:event-phase-at-target)
	
	;; (display "BUBBLE: ") (display (symbol->string event)) (newline)
	(event-annotate! e `(sdom:event-phase ,sdom:event-phase-bubbling))
	(for-each (lambda (x) (f x sdom:event-phase-bubbling)) 
		  (reverse a))
	#t))))