(define-record-type key-grab :key-grab
  (make-key-grab window keys message channel override?)
  key-grab?
  (window key-grab:window)
  (keys key-grab:keys)
  (message key-grab:message)
  (channel key-grab:channel)
  (override? key-grab:override?))

(define (create-grab-server dpy)
  (let ((in-channel (make-channel)))
    (spawn*
     'grab-server
     (lambda (release)
       (release)
       (let ((grabs '())
	     (event-cache '()))
	 (let loop ()
	   (let ((msg (receive in-channel)))
	     (case (car msg)
	       ((add-key-grab)
		(let* ((key-grab (second msg))
		       (first (car (key-grab:keys key-grab))))
		  (set! grabs (cons key-grab grabs))
		  (grab-key dpy (key:keycode first)
			    (key:modifiers first) (key-grab:window key-grab)
			    #f (grab-mode async) (grab-mode async))
		  (spawn* (list 'grabber 'on (key-grab:window key-grab))
			  (lambda (resume)
			    (call-with-event-channel
			     dpy (key-grab:window key-grab)
			     (event-mask key-press structure-notify)
			     (lambda (event-channel)
			       (resume)
			       (let loop ()
				 (let ((e (receive event-channel)))
				   (cond
				    ((destroy-window-event? e)
				     (send in-channel (list 'remove-key-grab
							    key-grab)))
				    ((eq? (event-type key-press)
					  (any-event-type e))
				     (send in-channel (list 'key-press e))
				     (loop))
				    (else (loop)))))))))))
	       ((remove-key-grab)
		(let* ((key-grab (second msg))
		       (first (car (key-grab:keys key-grab))))
		  (if (window-exists? dpy (key-grab:window key-grab))
		      (ungrab-key dpy (key:keycode first)
				  (key:modifiers first)
				  (key-grab:window key-grab)))
		  (set! grabs (filter (lambda (g) (not (eq? g key-grab)))
				      grabs))))
	       ((key-press)
		(let ((e (second msg))
		      (events (filter (lambda (x) x)
				      (map weak-pointer-ref event-cache))))
		  ;; because more of these can come in a row, we
		  ;; skip the ones already handled.
		  (if (memq e events)
		      #f
		      (begin
			(set! event-cache
			      (map make-weak-pointer (cons e events)))
			(let ((winner (do-grabs dpy grabs e)))
			  (if winner
			      (send (key-grab:channel winner)
				    (list (key-grab:message winner)
					  ;; this event ??
					  (key-event-time e)))))))))
	       ))
	   (loop)))))
    in-channel))

(define *grab-server* #f)
(define *grab-server-lock* (make-lock))

(define (grab-shortcut dpy window keys message channel override?)
  ;; assert |keys| > 0 ??
  (with-lock *grab-server-lock*
	     (lambda ()
	       (if (not *grab-server*)
		   (set! *grab-server* (create-grab-server dpy)))))
  (let ((key-grab (make-key-grab window keys message channel override?)))
    (send *grab-server* (list 'add-key-grab key-grab))
    key-grab))

;; unregister-key ??

(define (do-grabs dpy grabs event)
  (let* ((fwin (get-input-focus-window dpy)) ;; can be pointer-root and none
	 (path (reverse (if (or (equal? fwin none)
				(equal? fwin pointer-root))
			    (list (default-root-window dpy))
			    (window-path dpy fwin))))
	 ;; find all that match the first key and are registered for a
	 ;; window on the path
	 (grabs (flatten
		 (map (lambda (win)
			(filter
			 (lambda (grab)
			   (let ((first (car (key-grab:keys grab))))
			     (and (equal? win (key-grab:window grab))
				  (enum-set=? (key:modifiers first)
					      (key-event-state event))
				  (equal? (key:keycode first)
					  (key-event-keycode event)))))
			 grabs))
		      path)))
	 ;; make an alist mapping a grab to the keys that are not entered
	 (grabs-rests (map (lambda (g)
			     (cons g (cdr (key-grab:keys g))))
			   grabs))
	 (winner? (lambda (grabs-rests)
		    (let ((dones (map car (filter (lambda (grab-rest)
						    (null? (cdr grab-rest)))
						  grabs-rests))))
		      (let loop ((dones dones))
			(if (null? dones)
			    #f
			    (if (or (null? (cdr dones))
				    (key-grab:override? (car dones)))
				(car dones)
				(loop (cdr dones))))))))
	 (cursor (create-font-cursor dpy xc-icon))) ;; options?
    (grab-keyboard dpy (default-root-window dpy) #f
		   (grab-mode async) (grab-mode async) ;; ??
		   (key-event-time event))
    (define-cursor dpy (default-root-window dpy) cursor)
    (let ((result
	   (call-with-event-channel
	    dpy (default-root-window dpy) (event-mask key-press)
	    (lambda (event-channel)
	      (let loop ((grabs-rests grabs-rests))
		(and (not (null? grabs-rests))
		     (or (winner? grabs-rests)
			 (let ((e (receive event-channel)))
			   (cond
			    ((eq? (event-type key-press)
				  (any-event-type e))
			     (let ((rest
				    (filter
				     (lambda (grab-rest)
				       (and (not (null? (cdr grab-rest)))
					    (let ((next (car (cdr grab-rest))))
					      (enum-set=? (key:modifiers next)
							  (key-event-state e))
					      (equal? (key:keycode next)
						      (key-event-keycode e)))))
				       grabs-rests)))
			       (loop (map (lambda (grab-rest)
					    (cons (car grab-rest)
						  (cdr (cdr grab-rest))))
					  rest))))
			    (else (loop grabs-rests)))))))))))
      (undefine-cursor dpy (default-root-window dpy))
      (free-cursor dpy cursor)
      (ungrab-keyboard dpy current-time)
      result)))