(define-options-spec manager-options-spec
  (focus-policy symbol-list '(enter)) ;; enter, click
  (client-cursor cursor xc-X-cursor)
  )

(define-record-type wm :wm
  (make-wm type in-channel out-channel internal-out-channel
	   dpy window colormap options
	   clients current-client)
  wm?
  (type wm:type)
  (in-channel wm:in-channel)
  (out-channel wm:out-channel)
  (internal-out-channel wm:internal-out-channel)
  (dpy wm:dpy)
  (window wm:window)
  (colormap wm:colormap)
  (options wm:options)
  (clients wm:clients set-wm:clients!)
  (current-client wm:current-client set-wm:current-client!))

(define-record-discloser :wm
  (lambda (wm)
    `(Wm ,(manager-type-name (wm:type wm)) ,(wm:window wm))))

(define wm-clients wm:clients)
(define wm-current-client wm:current-client)

(define-enumerated-type manager-type :manager-type
  manager-type? manager-types manager-type-name manager-type-index
  (split switch move))

(define (manager-name type)
  (cond
   ((eq? type (manager-type split)) "split-wm")
   ((eq? type (manager-type switch)) "switch-wm")
   ((eq? type (manager-type move)) "move-wm")))

(define (create-wm dpy parent options default-options children
		   type options-spec out-channel fun)
  (let* ((wa (get-window-attributes dpy parent))
	 (main-window
	  (create-simple-window dpy parent 0 0 (window-attribute:width wa)
				(window-attribute:height wa)
				0 (white-pixel dpy) (black-pixel dpy)))
	 (colormap (create-colormap dpy main-window
				    (window-attribute:visual wa)
				    (colormap-alloc none)))
	 (in-channel (make-channel))
	 (internal-out-channel (make-channel))
	 (wm (make-wm type in-channel out-channel internal-out-channel
		      dpy main-window colormap
		      (create-options dpy colormap
				      (spec-defaults default-options
						     (options-spec-union
						      options-spec
						      manager-options-spec))
				      options)
		      '() #f)))

    (set-window-background-pixmap! dpy main-window parent-relative)
    ;; set properties ************************************************
    (set-wm-name! dpy main-window
		  (string-list->property (list (manager-name type))))
    ;; icon ??
    ;; size-hints ??
    (set-wm-hints! dpy main-window
		   (make-wm-hint-alist (input? #t)))
    ;; class-hint ??
    (set-wm-protocols! dpy main-window
		       (list (intern-atom dpy "WM_TAKE_FOCUS" #f)
			     (intern-atom dpy "WM_DELETE_WINDOW" #f)))
    (set-wm-hints! dpy main-window
		   (make-wm-hint-alist
		    (input? #t)))
			  
    ;; TODO: Colormaps
    
    ;; spawn handlers ************************************************
    (spawn* (list 'manager wm)
	    (lambda (release)
	      (call-with-event-channel
	       (wm:dpy wm) (wm:window wm)
	       (event-mask structure-notify
			   enter-window
			   focus-change
			   button-press
			   exposure)
	       (lambda (event-channel)
		 (call-with-current-continuation
		  (lambda (exit)
		    (release)
		    (send internal-out-channel '(fit-windows)) ;; ??
		    (let loop ()
		      (select*
		       (wrap (receive-rv event-channel)
			     (lambda (xevent)
			       (handle-xevent wm exit xevent)))
		       (wrap (receive-rv (wm:in-channel wm))
			     (lambda (msg)
			       (handle-external-message wm exit msg))))
		      (loop))))))
	      (free-colormap dpy colormap)))

    (for-each (lambda (window)
		(wm-manage-window wm window))
	      children)
    (fun wm internal-out-channel)))

(define (handle-xevent wm exit xevent)
  (let ((main-window (wm:window wm))
	(dpy (wm:dpy wm))
	(internal-out-channel (wm:internal-out-channel wm))
	(type (any-event-type xevent)))
    (cond
     ((expose-event? xevent)
      (if (= 0 (expose-event-count xevent))
	  (send internal-out-channel '(draw-main-window))))

     ((configure-event? xevent)
      (send internal-out-channel '(fit-windows)))

     ((focus-change-event? xevent)
      (if (window-exists? dpy (wm:window wm))
	  (let ((mode (focus-change-event-mode xevent))
		(detail (focus-change-event-detail xevent)))
	    (if (and (eq? mode (notify-mode normal))
		     (memq detail (list (notify-detail nonlinear)
					(notify-detail nonlinear-virtual)
					(notify-detail virtual)
					(notify-detail ancestor))))
		(let ((focused? (eq? (event-type focus-in)
				     (focus-change-event-type xevent))))
		  (send internal-out-channel
			(list 'update-manager-state focused?)))))))

     ;; the manager got the focus (as a client)
     ((client-message-event? xevent)
      (let* ((p (client-message-event-property xevent))
	     (type (property:type p)))
	(if (equal? type (intern-atom dpy "WM_PROTOCOLS" #f))
	    (let ((name (car (property:data p)))
		  (time (cadr (property:data p))))
	      (if (equal? name (intern-atom dpy "WM_TAKE_FOCUS" #f))
		  (begin
		    (if (window-viewable? dpy main-window)
			(set-input-focus dpy main-window (revert-to parent)
					 current-time))
		    (send internal-out-channel
			  (list 'manager-focused current-time))))
	      (if (equal? name (intern-atom dpy "WM_DELETE_WINDOW" #f))
		  (if (null? (wm:clients wm))
		      ;; (destroy-wm wm) would dead-lock
		      (handle-external-message wm exit '(destroy-manager))
		      (bell dpy 100)))
	      ))))

     ((button-event? xevent)
      (if (eq? (event-type button-press) (button-event-type xevent))
	  (take-focus dpy main-window (button-event-time xevent))))

     ((destroy-window-event? xevent)
      (exit 'destroy))
     )))

(define (handle-external-message wm exit msg)
  (let ((internal-out-channel (wm:internal-out-channel wm))
	(dpy (wm:dpy wm)))
    (case (car msg)
      ((wait)
       (let ((sp (second msg))
	     (message (third msg)))
	 (handle-external-message wm exit message)
	 (sync-point-release sp)))
      
      ((manage-window)
       (let ((window (second msg))
	     (maybe-rect (third msg)))
	 (let ((client (create-client wm window)))
	   (set-wm:clients! wm (append (wm:clients wm) (list client)))
	   (send-message+wait internal-out-channel
			      (list 'init-client client maybe-rect)))))
      
      ((configure-window)
       (let ((window (second msg))
	     (changes (third msg)))
	 (send-message+wait internal-out-channel
			    (list 'configure-window window changes))))
      
      ((unmanage-window)
       (let* ((window (second msg))
	      (client (find (lambda (c)
			      (eq? window (client:window c)))
			    (wm:clients wm))))
	 (if (and client (window-exists? dpy window))
	     (reparent-to-root dpy window))))

      ((iconify-window)
       (let* ((window (second msg))
	      (client (find (lambda (c)
			      (eq? window (client:window c)))
			    (wm:clients wm))))
	 (if client
	     (send internal-out-channel
		   (list 'iconify-client client)))))

      ((maximize-window)
       (let* ((window (second msg))
	      (client (find (lambda (c)
			      (eq? window (client:window c)))
			    (wm:clients wm))))
	 (if client
	     (send internal-out-channel
		   (list 'maximize-client client)))))
      
      ((destroy-manager)
       (send-message+wait internal-out-channel '(deinit-manager))
       (if (window-exists? dpy (wm:window wm))
	   (destroy-window dpy (wm:window wm))))
      
      ((deinit-client)
       (let ((client (second msg)))
	 (set-wm:clients! wm (filter (lambda (c) (not (eq? c client)))
				     (wm:clients wm)))
	 (send-message+wait (wm:internal-out-channel wm)
			    (list 'deinit-client client))
	 (if (eq? client (wm:current-client wm))
	     (set-wm:current-client! wm #f))
	 (destroy-window dpy (client:client-window client))))
      
      ((select-client)
       (let* ((client (second msg))
	      (time (third msg))
	      (all (cons client (transients-for-client wm client)))
	      (top (last all)))
	 (if (not (eq? top (wm:current-client wm)))
	     (begin
	       (send-message+wait (wm:internal-out-channel wm)
				  (list 'show-clients all))
	       (set-wm:current-client! wm top)))
	 (if (window-exists? dpy (client:window top))
	     (take-focus dpy (client:window top) time))))
      
      (else (warn "unhandled manager message" wm msg)))))

(define (wm-deinit-client wm client)
  (send (wm:in-channel wm) (list 'deinit-client client)))

;; *** external messages *********************************************

(define (wm-manage-window wm window . rect)
  (let ((maybe-rect (if (null? rect)
			#f
			(car rect))))
    (send-message+wait (wm:in-channel wm)
		       (list 'manage-window window maybe-rect))))

(define (wm-configure-window wm window changes)
  (send-message+wait (wm:in-channel wm)
		     (list 'configure-window window changes)))

(define (wm-unmanage-window wm window)
  (send (wm:in-channel wm) (list 'unmanage-window window)))

(define (wm-iconify-window wm window)
  (send (wm:in-channel wm) (list 'iconify-window window)))

(define (wm-maximize-window wm window)
  (send (wm:in-channel wm) (list 'maximize-window window)))

(define (wm-select-client wm client time)
  (spawn (lambda ()
	   (send (wm:in-channel wm) (list 'select-client client time)))))

(define (destroy-wm wm)
  (send-message+wait (wm:in-channel wm) '(destroy-manager)))

(define (send-root-drop wm window x y)
  (send (wm:out-channel wm) (list 'root-drop window x y)))

;; *** client ********************************************************

(define-record-type client :client
  (make-client window client-window in-channel data focused?)
  client?
  (window client:window set-client:window!)
  (client-window client:client-window)
  (in-channel client:in-channel)
  (data client:data set-client:data!)
  (focused? client:focused? set-client:focused?!))

(define (set-client-focused?! wm client focused?)
  (let ((prev (client:focused? client)))
    (if (not (eq? prev focused?))
	(begin
	  (set-client:focused?! client focused?)
	  (send (wm:internal-out-channel wm)
		(list 'update-client-state client focused?))))))

(define-record-discloser :client
  (lambda (c)
    `(Client ,(client:window c) in ,(client:client-window c))))

(define (create-client wm window)
  (let* ((dpy (wm:dpy wm))
	 (client-window (create-simple-window dpy (wm:window wm)
					      0 0
					      (window-width dpy window)
					      (window-height dpy window)
					      0
					      (white-pixel dpy)
					      (black-pixel dpy)))
	 (in-channel (make-channel))
	 (client (make-client window client-window in-channel #f #f)))
    ;; transparent by default.
    (set-window-background-pixmap! dpy client-window parent-relative)
    (define-cursor dpy client-window
      (get-option-value (wm:options wm) 'client-cursor))
    (if (memq 'click (get-option-value (wm:options wm) 'focus-policy))
	;; Note: won't work recursively (manager in manager)
	(grab-button dpy (button button1) (state-set) client-window
		     #t (event-mask button-press button-release)
		     (grab-mode sync) (grab-mode async) none none))
    (reparent-window dpy window client-window 0 0)
    (create-client-handler wm client)
    client))

(define (create-client-handler wm client)
  (spawn*
   (list 'client-handler wm client)
   (lambda (release)
     (call-with-event-channel
      (wm:dpy wm) (client:client-window client)
      (event-mask exposure
		  enter-window
		  button-press
		  structure-notify
		  substructure-redirect)
      (lambda (client-window-channel)
	(call-with-event-channel
	 (wm:dpy wm) (client:window client)
	 (event-mask property-change
		     focus-change
		     structure-notify)
	 (lambda (client-channel)
	   (call-with-current-continuation
	    (lambda (exit)
	      (release)
	      (let loop ()
		(select*
		 (wrap (receive-rv (client:in-channel client))
		       (lambda (msg)
			 (case (car msg)
			   ((restart-handler)
			    (create-client-handler wm client)
			    (sync-point-release (second msg))
			    (exit 'restart))
			   (else (warn "unhandled client message" wm
				       client msg)))))
		 (wrap (receive-rv client-window-channel)
		       (lambda (xevent)
			 (handle-client-window-xevent wm exit client xevent)))
		 (wrap (receive-rv client-channel)
		       (lambda (xevent)
			 (handle-client-xevent wm exit client xevent))))
		(loop)))))))))))

(define (client-of-window wm window)
  (find (lambda (client)
	  (equal? window (client:window client)))
	(wm-clients wm)))

(define (client-replace-window wm old-window new-window)
  (let ((client (client-of-window wm old-window))
	(internal-out-channel (wm:internal-out-channel wm))
	(dpy (wm:dpy wm)))
    (if client
	(begin
	  (set-client:window! client new-window)
	  (if (not (equal? (window-parent dpy new-window)
			   (client:client-window client)))
	      (reparent-window dpy new-window (client:client-window client)
			       0 0))
	  (let ((sp (make-sync-point)))
	    (send (client:in-channel client)
		  (list 'restart-handler sp))
	    (sync-point-wait sp))
	  (send-message+wait internal-out-channel (list 'fit-client client))
	  (send internal-out-channel
		(list 'update-client-name client (client-name dpy client)))
	  (map-window (wm:dpy wm) new-window))
	#f)))

(define (handle-client-window-xevent wm exit client xevent)
  (let ((type (any-event-type xevent))
	(internal-out-channel (wm:internal-out-channel wm))
	(dpy (wm:dpy wm)))
    (cond
     ((expose-event? xevent)
      (if (= 0 (expose-event-count xevent))
	  (send internal-out-channel
		(list 'draw-client-window client))))
     ((configure-event? xevent)
      (if (window-exists? dpy (client:window client))
	  (send internal-out-channel (list 'fit-client client))))
     ((configure-request-event? xevent)
      (let ((changes (configure-request-event-window-change-alist xevent)))
	(if (or (assq (window-change width) changes)
		(assq (window-change height) changes)
		(assq (window-change border-width) changes))
	    (begin
	      (configure-window dpy (client:window client)
				(filter (lambda (a.v)
					  (memq (car a.v)
						(list (window-change width)
						      (window-change height))))
					changes))
	      (send internal-out-channel (list 'fit-client-window client)))
	    (send-configuration dpy (client:window client)))))
;;     ((circulate-event? xevent)
;;      (send internal-out-channel (list 'update-client-state client)))
     ((eq? (event-type enter-notify) type)
      (if (and (memq 'enter (get-option-value (wm:options wm) 'focus-policy))
	       (window-exists? dpy (client:window client))
	       (not (eq? client (wm-current-client wm)))
	       (not (window-contains-focus? dpy (client:window client))))
	  (if (ignore-next-enter-notify?)
	      (begin
		(accept-next-enter-notify!)
		(if (not (wm-current-client wm))
		    (wm-select-client wm client (crossing-event-time xevent))))
	      (wm-select-client wm client (crossing-event-time xevent)))))

     ((eq? (event-type button-press) type)
      (if (memq 'click (get-option-value (wm:options wm) 'focus-policy))
	  (begin
	    (wm-select-client wm client (button-event-time xevent))
	    (if (not (eq? (button-event-subwindow xevent)
			  (client:client-window client)))
		(allow-events dpy (event-mode replay-pointer)
			      (button-event-time xevent))
		(allow-events dpy (event-mode async-pointer)
			      (button-event-time xevent))))))

     ((destroy-window-event? xevent)
      (exit 'destroy)))))

(define (handle-client-xevent wm exit client xevent)
  (let ((type (any-event-type xevent))
	(internal-out-channel (wm:internal-out-channel wm))
	(dpy (wm:dpy wm)))
    (cond
     ((focus-change-event? xevent)
      (if (window-exists? dpy (client:window client))
	  (let ((mode (focus-change-event-mode xevent))
		(detail (focus-change-event-detail xevent)))
	    (if (and (eq? mode (notify-mode normal))
		     (memq detail (list (notify-detail nonlinear)
					(notify-detail nonlinear-virtual)
					(notify-detail virtual)
					(notify-detail ancestor))))
		(if (eq? (event-type focus-in)
			 (focus-change-event-type xevent))
		    (begin
		      (install-colormaps dpy (client:window client))
		      (set-client-focused?! wm client #t))
		    (begin
		      (uninstall-colormaps dpy (client:window client))
		      (set-client-focused?! wm client #f)))))))
     
     ((property-event? xevent)
      (if (window-exists? dpy (client:window client))
	  (let ((name (get-atom-name (property-event-display xevent)
				     (property-event-atom xevent))))
	    (cond
	     ((equal? "WM_NAME" name)
	      (send internal-out-channel
		    (list 'update-client-name client
			  (client-name dpy client))))))))

     ((reparent-event? xevent)
      (if (and (window-exists? dpy (client:window client))
	       (not (eq? (client:client-window client)
			 (window-parent dpy (client:window client)))))
	  (begin
	    ;; window has been reparented away
	    (wm-deinit-client wm client)
	    (exit 'reparent))))
     ((destroy-window-event? xevent)
      (if (eq? (client:window client) (destroy-window-event-event xevent))
	  (begin
	    (wm-deinit-client wm client)
	    (exit 'destroy))))

     ((map-event? xevent)
      (let* ((s.i (get-wm-state dpy (client:window client)))
	     (s (and s.i (car s.i))))
	(if (eq? (wm-state iconic) s)
	    ;; iconic -> normal transition
	    (send (wm:internal-out-channel wm)
		  (list 'normalize-client client)))))
     )))

(define (transients-for-client wm client)
  (filter (lambda (c)
	    (and (not (eq? c client))
		 (equal? (client:window client)
			 (get-transient-for (wm:dpy wm) (client:window c)))))
	  (wm:clients wm)))

;; ignoring the next enter-notify
(define (ignore-next-enter-notify!)
  (set! *ignore-next-enter-notify* #t))

(define (ignore-next-enter-notify?)
  *ignore-next-enter-notify*)

(define *ignore-next-enter-notify* #f)

(define (accept-next-enter-notify!)
  (set! *ignore-next-enter-notify* #f))


;; *** client names **************************************************

(define *client-names* '()) ;; (window oname name)
(define *client-names-lock* (make-lock))

(define (client-name dpy client)
  (let* ((w (client:window client))
	 (cname (if (window-exists? dpy w)
		    (let* ((p (get-wm-name dpy w))
			   (l (if p (property->string-list p) '())))
		      (if (null? l)
			  "<untitled>"
			  (car l)))
		    "<untitled>")))
    (with-lock *client-names-lock*
	       (lambda ()
		 (let ((name? (let ((p (assq w *client-names*)))
				(and p (equal? (cadr p) cname)
				     (caddr p)))))
		   (set! *client-names*
			 (filter (lambda (e)
				   (and (not (eq? (car e) w))
					(window-exists? dpy (car e))))
				 *client-names*))
		   (let ((name (if name? name?
				   (unique-name cname
						(map caddr *client-names*)))))
		     (set! *client-names* (cons (list w cname name)
						*client-names*))
		     name))))))

(define (unique-name name names)
  (if (not (member name names))
      name
      (let loop ((i 1))
	(let ((n (string-append name "<" (number->string i) ">")))
	  (if (member n names)
	      (loop (+ i 1))
	      n)))))

(define (find-window-by-name name)
  (with-lock *client-names-lock*
	     (lambda ()
	       (let ((l (filter (lambda (w.o.n)
				  (equal? (third w.o.n) name))
				*client-names*)))
		 (and (not (null? l)) (first (car l)))))))

(define (get-all-window-names)
  (with-lock *client-names-lock*
	     (lambda ()
	       (map (lambda (w.o.n)
		      (cons (first w.o.n) (third w.o.n)))
		    *client-names*))))