;;; rmail-labelsorter.el
;;; ========================
;;; Managing labels in Rmail
;;; ========================
;;;
;;; Copyright (C) 1995 John Maraist  maraist@ira.uka.de
;;; Version 1.1


;;; This program 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 1, or (at your option)
;;; any later version.
;;;
;;; This program 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.
;;;
;;; A copy of the GNU General Public License can be obtained from the
;;; author of this program at the email address above; from the Free
;;; Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA;
;;; or from most emacs implementations from the main "Help" or "Info"
;;; screens.


;;; This file *really* needs documentation but I don't have time right
;;; now.  Check back soon or send me email & I'll let you know when
;;; the docs are finished, or at least usable.


;;; Version history:
;;;
;;;;; -- 1.0 -- 29 August 1995 --
;;;;; Initial release.
;;;
;;;;; -- 1.1 -- 8 October 1995 --
;;;;; Allow buffer-local (determined by the buffer name) tagging
;;;;; schemes; separated the insinuation into rmail into an rmail-mode
;;;;; hook. 
;;;
;;;;; -- 1.1.0a -- planned --
;;;;; Added documentation.

(provide 'rmail-labelsorter)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Default variable declarations ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar buffer-local-unified-tag-structures
  nil
  "Buffer-name/local unified tag structure association list.")
(defvar labelsorter-sortkeymap
  nil
  "Internal variable for rmail-labelsorter module")
(defvar labelsorter-groupmap
  nil
  "Internal variable for rmail-labelsorter module")
(defvar labelsorter-exclusions
  nil
  "Internal variable for rmail-labelsorter module")
(defvar labelsorter-menubar-item
  nil
  "Internal variable for rmail-labelsorter module")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Deriving substructures ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; Single call to derive all substructures

(defun update-tag-structures ()
  (interactive)
  (let ((l (extract-labelsort-vectors-iter (cdr unified-tag-structure))))
    (setq labelsorter-sortkeymap  (make-labelsorter-sortkeymap  l))
    (setq labelsorter-groupmap (make-labelsorter-groupmap l))
    (setq labelsorter-exclusions (make-labelsorter-exclusions '() l))
    (setq labelsorter-menubar-item (make-labelsorter-menubar-item))
    ;; (setq labelsorter-tagmenu (make-labelsorter-tagmenu unified-tag-structure))
    
    (insert-labelsorter-menu)
    ))

;;;; Sort key map:
;;;; Takes a label name, returns its sorting key.

(defun make-labelsorter-sortkeymap (l)
  (if (null l)
      '()
    (let ((i (car l)))
      (cons (cons (aref i 0) (aref i 1))
	    (make-labelsorter-sortkeymap (cdr l))))))

;;;; Group map:
;;;; Takes a label name, returns its group name.

(defun make-labelsorter-groupmap (l)
  (if (null l)
      '()
    (let ((i (car l)))
      (cons (cons (aref i 0) (aref i 2))
	    (make-labelsorter-groupmap (cdr l))))))

;;;; Exclusions map:
;;;; Takes a group names, returns the tags in the group

(defun make-labelsorter-exclusions (excl l)
  (if (null l)
      excl
    (let ((la (car l)))
      (make-labelsorter-exclusions 
       (add-labelsorter-exclusion excl (aref la 2) (aref la 0))
       (cdr l)))))

(defun add-labelsorter-exclusion (excl grp tag)
  (if (null excl) 
      (list (cons grp (list tag)))
    (let ((e (car excl)) ; the first exclusion
	  (es (cdr excl))) ; the rest of the exclusion list
      (let ((e1 (car e)) ; the group name
	    (e2 (cdr e))) ; the members of the group
	(if (equal grp e1)
	    (cons (cons e1 (cons tag e2)) es)
	  (cons e (add-labelsorter-exclusion es grp tag)))
	))))

(defun extract-labelsort-vectors-iter (l)
  (if (null l)
      '()
    (let* ((c1 (car l))
	   (c2 (cdr l))
	   (trg (cdr c1)))
      (if (vectorp trg)
	  (cons trg 
		(extract-labelsort-vectors-iter c2))
	(append (extract-labelsort-vectors-iter (cdr trg))
		(extract-labelsort-vectors-iter c2))
	))))

;;;; Menubar item:
;;;; Takes nothing, returns a menubar based on the unified-tag-structure

(defun make-labelsorter-menubar-item ()
  (tag-structure-to-menu unified-tag-structure))

(defun tag-structure-to-menu (tag-str)
  "Internal routine - derive whole menubar item from whole tag structure."
  ;; This is the top-level routine, which is non-recursive 
  ;; since the top of the menu is handled a little bit differently
  ;; from the rest of the thing.
  (cons (aref (car tag-str) 1) 
	(recur-tag-str-to-menu (cdr tag-str) " ß"))
  )

(defun recur-tag-str-to-menu (tag-str key-string)
  "Internal routine - derive menubar item sub-structure from a tag sub-structure."
  (if (null tag-str)
      nil
    (let ((next-line (recur-tag-str-to-menu (cdr tag-str) key-string)))
      (if (< 0 (car (car tag-str)))
	  (cons (this-tag-item-to-menu-item (car tag-str) key-string) next-line)
	next-line))))

(defun this-tag-item-to-menu-item (tag-item key-string)
  "Internal routine - derive single menubar entry from a tag entry."
  (let ((new-key-string  (concat key-string " " (char-to-string (car tag-item))))
	(sub-str         (cdr tag-item)))
    (cond ((listp sub-str)   (cons (concat (aref (car sub-str) 1)
					   " (" 
					   (substring new-key-string 1)
					   " -)")
				   (recur-tag-str-to-menu (cdr sub-str) 
							  new-key-string)))
	  ((vectorp sub-str) (let ((add-sym   (intern (concat "ADD "  new-key-string)))
				   ; (kill-sym  (intern (concat "KILL " new-key-string)))
				   (the-sym   (aref sub-str 0))
				   (the-group (aref sub-str 2))
				   )
			       (fset add-sym 
				     (list 'lambda '() 
					   '(interactive)
					   (list 'exclude-group (if (listp the-group)
								    the-group
								  (list 'list the-group)))
					   (list 'correctly-add-label the-sym)))
			       ; (fset kill-sym 
			       ;     (function () (rmail-seek-tag-and-erase the-sym)))
			       (vector the-sym add-sym :keys new-key-string)))
	  (t                 (message "Bad tag entry structure")))))

(defun insert-labelsorter-menu ()
  (set-buffer-menubar (insert-before-nil-entry labelsorter-menubar-item
					       (kill-tags-entry current-menubar))))

(defun kill-tags-entry (menu)
  (cond ((null menu)                nil)
	((listp (car menu))         (if (stringp (car (car menu)))
					(if (string= "Tags" (car (car menu)))
					    (cdr menu)
					  (cons (car menu)
						(kill-tags-entry (cdr menu))))
				      (cons (car menu)
					    (kill-tags-entry (cdr menu)))))
	((vectorp (car menu))       (if (stringp (aref (car menu) 0))
					(if (string= "Tags" (aref (car menu) 0))
					    (cdr menu)
					  (cons (car menu)
						(kill-tags-entry (cdr menu))))
				      (cons (car menu)
					    (kill-tags-entry (cdr menu)))))
	(t                          (cons (car menu)
					  (kill-tags-entry (cdr menu))))))
	 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Runtime routines for adding/removing tags ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;; Basics: figure out the right add/kill label functions

(defun correctly-add-label (s)
  (if (equal mode-name "RMAIL")
      (rmail-add-label s)
    (if (equal mode-name "RMAIL Summary")
	(rmail-summary-add-label s)
      (error "Can only add labels in \"RMAIL\" and \"RMAIL Summary\" modes."))))

(defun correctly-kill-label (s)
  (if (equal mode-name "RMAIL")
      (rmail-kill-label s)
    (if (equal mode-name "RMAIL Summary")
	(rmail-summary-kill-label s)
      (error "Can only kill labels in \"RMAIL\" and \"RMAIL Summary\" modes."))))

;;;; Most of the work is done by the following two functions.

;;;; I. get-tag (and subcalls)

(defun get-tag (pr s)
  (get-tag-real pr (aref (car s) 0) (cdr s)))

(defun get-tag-real (pr pr2 table)
  (let* ((c nil)
	 (inp-char 0)
	 )
    (fset 'get-tag-type 
	  (list 'lambda '(c) 
		(list 'interactive 
		      (concat "c" pr pr2))
				'c))
    (while (null c)
      (setq inp-char (call-interactively 'get-tag-type))
      (setq c (assoc inp-char table))
      (if (null c) 
	  (princ "Unrecognized character!" t)
	(setq c (cdr c)))
		      )
    (if (vectorp c)
	(let ((ct (aref c 0)))
	  (if (string= ct "")
	      (while (not (string= ct ""))
		(setq ct (read-string (concat pr "literal tag name: "))))
	    ct))
      (get-tag pr c))))

;;;; II: exclude-group

(defun exclude-group (gs)
  (if (null gs)
      nil
    (progn 
      (correctly-kill-label (car gs))
      (exclude-group (cdr gs)))))
      
;;;; First level of calls
      
(defun rmail-seek-tag-and-add-excluding-group ()
  (interactive)
  (let* ( (tag          (get-tag "Add " unified-tag-structure))
	  (group-name   (let ((pair (assoc tag labelsorter-groupmap)))
			  (if pair
			      (cdr pair)
			    nil)))
	  (group-members (if group-name
			     (let ((pair (assoc group-name 
						labelsorter-exclusions)))
			       (if pair
				   (cdr pair)
				 nil))
			   nil))
	  )
    (exclude-group group-members)
    (correctly-add-label tag)))f

(defun rmail-seek-tag-and-remove ()
  (interactive)
  (correctly-kill-label (get-tag "Remove " unified-tag-structure)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Sorting by distinguished labels ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(setq rmail-label-sorting-unlabelled-code 99999)

(defun rmail-label-sorting-key-loop (msg str)
  (if (null str)
      rmail-label-sorting-unlabelled-code
    (let ((top (car str))
	  (str-rest (cdr str)))
      (let ((match (car top))
	    (code (cdr top)))
	(if (rmail-message-labels-p msg match)
	    code
	  (rmail-label-sorting-key-loop msg str-rest))))))

(defun rmail-custom-sort-from-labels (reverse)
  "Sort messages according to the labelsorter-sortkeymap structure."
  (interactive "P")
  (rmail-sort-messages reverse 
		       (function 
			(lambda (msg)
			  (rmail-label-sorting-key-loop msg labelsorter-sortkeymap))))
  (rmail-last-message))
(defun rmail-summary-custom-sort-from-labels (reverse)
  "Sort summary lines according to the labelsorter-sortkeymap structure."
  (interactive "P")
  (rmail-sort-from-summary (function rmail-custom-sort-from-labels) reverse))

;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Standard hooks ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;

(defun rmail-labelsorter-std-hook ()
  (let ((local-pair (assoc (buffer-name)
			   buffer-local-unified-tag-structures)))
    (if local-pair
	(progn (make-local-variable 'unified-tag-structure)
	       (make-local-variable 'labelsorter-sortkeymap)
	       (make-local-variable 'labelsorter-groupmap)
	       (make-local-variable 'labelsorter-exclusions)
	       (make-local-variable 'labelsorter-menubar-item)
	       (setq unified-tag-structure (cdr local-pair))
	       (update-tag-structures))))
  (insert-labelsorter-menu))
(defun rmail-summary-labelsorter-std-hook ()
  (let ((local-pair (assoc (buffer-name)
			   buffer-local-unified-tag-structures)))
    (if local-pair
	(progn (make-local-variable 'unified-tag-structure)
	       (make-local-variable 'labelsorter-sortkeymap)
	       (make-local-variable 'labelsorter-groupmap)
	       (make-local-variable 'labelsorter-exclusions)
	       (make-local-variable 'labelsorter-menubar-item)
	       (setq unified-tag-structure (cdr local-pair))
	       (update-tag-structures))))
  (insert-labelsorter-menu))

;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Initialization ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;

(update-tag-structures)