;; beos-window-menu.jl -- hack to change window-menu to approximate BeOS

;; Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>

;; This file is part of sawfish.

;; sawfish 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, or (at your option)
;; any later version.

;; sawfish 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 sawfish; see the file COPYING.  If not, write to
;; the Free Software Foundation, 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA.

(define-structure sawfish.wm.ext.beos-window-menu

    (export beos-window-menu)

    (open rep
	  rep.util.utf8
	  sawfish.wm.windows
	  sawfish.wm.misc
	  sawfish.wm.custom
	  sawfish.wm.workspace
	  sawfish.wm.viewport
	  sawfish.wm.util.groups
	  sawfish.wm.util.display-window
	  sawfish.wm.menus)

  (define-structure-alias beos-window-menu sawfish.wm.ext.beos-window-menu)

  (define (abbreviate name #!optional len)
    (unless len (setq len 20))
    (if (> (utf8-string-length name) len)
	(concat (utf8-substring name 0 len) "...")
      name))

  (define (make-label w)
    (let ((name (window-name w))
	  (would-switch (or (not (window-appears-in-workspace-p
				  w current-workspace))
			    (window-outside-viewport-p w))))
      (quote-menu-item (concat (cond ((window-get w 'iconified) ?\[)
				     (would-switch ?\())
			       (abbreviate name)
			       (cond ((window-get w 'iconified)  ?\])
				     (would-switch ?\)))))))

  (define windows-left (make-fluid))

  (define (make-item w)
    (fluid-set windows-left (delq w (fluid windows-left)))
    (list (make-label w)
	  (lambda ()
	    (when (windowp w)
	      (display-window w)))
	  (cons 'check (and (eq (input-focus) w)))
	  '(group . beos-window-menu)))

  (define (group-name id)
    (cond ((symbolp id) (symbol-name id))
	  ((integerp id)
	   (let ((name (or (and (> id 0) (window-class id))
			   (and (> id 0) (nth 2 (get-x-property id 'WM_NAME)))
			   (window-class (car (windows-by-group id)))
			   "Unnamed")))
	     (abbreviate name)))))

  (define (window-suitable-p w)
    (and (memq w (fluid windows-left))
	 (window-mapped-p w)
	 (or (window-get w 'iconified)
	     (and (not (window-get w 'window-list-skip))
		  (not (window-get w 'ignored))
		  (not (desktop-window-p w))))))

  (define (make-group-item id)
    (let loop ((menu '())
	       (windows (windows-by-group id)))
         (if (null windows)
             (cons (group-name id) (nreverse menu))
           (if (window-suitable-p (car windows))
               (loop (cons (make-item (car windows)) menu) (cdr windows))
             (loop menu (cdr windows))))))

  (define (cleanup-menu menu)
    ;; sort the group names..
    (setq menu (sort menu (lambda (x y)
			    (not (string-lessp (car x) (car y))))))
    ;; ..then merge any identically named sub-menus
    (let loop ((rest menu))
         (when (cdr rest)
           (if (string= (caar rest) (caadr rest))
               (progn
                 (rplacd (car rest) (nconc (cdar rest) (cdadr rest)))
                 (rplacd rest (cddr rest))
                 (loop rest))
             (loop (cdr rest)))))
    menu)

  (define (make-menu)
    (let-fluids ((windows-left (managed-windows)))
                (let loop-1 ((menu '())
                             (groups (window-group-ids)))
                     (if (null groups)
                         (progn
                           (setq menu (cleanup-menu menu))
                           (let ((left (delete-if-not window-suitable-p
                                                      (fluid windows-left))))
                             (if left
                                 (let loop-2 ((menu (cons '() menu))
                                              (rest left))
                                      (if (null rest)
                                          menu
                                        (loop-2 (cons (make-item (car rest))
                                                      menu)
                                                (cdr rest))))
                               menu)))
                       (loop-1 (let ((item (make-group-item (car groups))))
                                 (if (cdr item)
                                     (cons item menu)
                                   menu))
                               (cdr groups))))))

  (define (simplify menu)
    (let loop ((rest menu)
	       (out '()))
         (if (null rest)
             out
           (let ((next (cdr rest)))
             ;; reverse the pointers
             (rplacd rest out)
             (when (= (length (cdar rest)) 1)
               (rplaca rest (cadar rest)))
             (loop next rest)))))

  (define (beos-window-menu) (simplify (make-menu)))

  (setq window-menu beos-window-menu))
