;;; mws.el --- static work spaces

;; Copyright (c) 2006-2009 Nhat Minh Lê <nhat.minh.le@huoc.org>

;; Permission to use, copy, modify, and/or distribute this software
;; for any purpose with or without fee is hereby granted, provided
;; that the above copyright notice and this permission notice appear
;; in all copies.

;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

(defgroup mws nil
  "Static work spaces."
  :group 'convenience)

(defcustom mws-reorder-new-buffers-at-end t
  "If non-nil, means to put new buffers at the end of the buffer
list when reordering. Otherwise, they appear at the front.

While it is quite a natural behavior, it is costly."
  :type 'boolean
  :group 'mws)

(defcustom mws-local-buffer-list t
  "Each layout has its own buffer list if non-nil. All share one
if nil."
  :type 'boolean
  :group 'mws)

(defun mws-reorder-buffer-list (new-list)
  "Reorder buffer list."
  (let ((merged-list
	 (if (not mws-reorder-new-buffers-at-end)
	     new-list
	   (let ((tmp-list (buffer-list)))
	     (mapc (lambda (x)
		     (setq tmp-list (delq x tmp-list))) new-list)
	     (append new-list tmp-list)))))
    (while merged-list
      (bury-buffer (car merged-list))
      (setq merged-list (cdr merged-list)))))

(unless (fboundp 'set-frame-parameter)
  (defun set-frame-parameter (frame parameter value)
    (modify-frame-parameters frame
			     (list (cons parameter value)))))

(defun mws-delete-layout (index)
  "Delete layout index by INDEX.

INDEX can be anything but if invoked interactively, only numbers
are accepted."
  (interactive "nDelete work space: ")
  (when (= index (frame-parameter nil 'mws-current-layout))
    (error "Trying to delete current layout"))
  (set-frame-parameter nil 'mws-layout-alist
		       (assq-delete-all
			index
			(frame-parameter 'mws-layout-alist))))

(defun mws-visible-list ()
  "Return a list of visible buffers.

Buffers shown multiple times are duplicated in the list."
  (mapcar (lambda (x) (window-buffer x))
	  (window-list)))

(defun mws-save-layout (index)
  "Save current layout to INDEX. Return layout."
  (let ((lay (list (current-window-configuration)
		   (buffer-list)	; XXX: needs copy-list?
		   (mws-visible-list)
		   (point-marker))))
    (set-frame-parameter
     nil
     'mws-layout-alist
     (cons (cons index lay)
	   (assq-delete-all
	    index
	    (frame-parameter nil 'mws-layout-alist))))
    lay))

(defun mws-set-layout (index)
  "Update internal status and set global layout."
  (let ((layout (cdr (assq index (frame-parameter nil 'mws-layout-alist)))))
    (when (null layout)
      (setq layout (mws-save-layout index)))
    (when mws-local-buffer-list
      (mws-reorder-buffer-list (cadr layout)))
    (set-window-configuration (car layout))
    (let ((pm (cadr (cddr layout))))
      (when (marker-position pm)
	(goto-char pm)))))

(defun mws-switch-to-layout (index &optional nosave)
  "Switch to layout INDEX.

INDEX can be anything but if invoked interactively, only numbers
are accepted.

With a prefix argument, do not save current configuration."
  (interactive "nSwitch to layout: \nP")
  (let ((current-layout (frame-parameter nil 'mws-current-layout)))
    (if (= index current-layout)
	(mws-set-layout current-layout)
      (when (null nosave)
	(mws-save-layout current-layout))
      (mws-set-layout index)
      (set-frame-parameter nil 'mws-current-layout index))))

(defun mws-init-frame (frame)
  "Initialize frame parameters `mws-layout-alist' and
`mws-current-layout'."
  (set-frame-parameter frame 'mws-layout-alist nil)
  (set-frame-parameter frame 'mws-current-layout 0))

;; Frames need to be initialized.
(add-hook 'after-make-frame-functions 'mws-init-frame)
(mws-init-frame nil)

(provide 'mws)