;;; filter.el
;;;
;;; Similar to outline mode, but more flexible. It lets you classify
;;; each line of a file into one or more types, and then display
;;; different sets of those types. I did something similar in outline
;;; mode, but it was very difficult to get function comment headers to
;;; show up with the functions.
;;;
;;; c 2011 russell young
;;; emacs@young-0.com
;;; Open source: anyone can use, distribute, or modify, but please
;;; leave in the attribution

(defvar  filter... t
  "Display the ... in place of hidden lines")

(defvar filter-modes 
	  '((foxpro-prog-mode
		 ((toplevel-def "\\(protected +\\|hidden +\\)?\\(function\\|procedure\\|define +class\\)")
		  (sublevel-def "\\(\t\\\| \\{1,7\\}\\)\\(protected +\\|hidden +\\)?\\(function\\|procedure\\|define +class\\)")
		  (toplevel-comment "\\*\\*")
		  (empty "[ \t]*$")
		  (sublevel-comment "\\(\t\\| \\{1,7\\}\\)\\*\\*"))
		 ((top (toplevel-def) ("t" "1"))
		  (top-comments (toplevel-def toplevel-comment) ("2"))
		  (sub (top sublevel-def) ("d" "3"))
		  (sub-comments (sub toplevel-comment sublevel-comment) ("4")))
		 )
		)
	  "These are the modes the filter knows about. Each is a list (MODE TYPES FILTERS). 
 - MODE is the mode that this filter works for.
 - TYPES are the instructions to classify each line. These are lists (TYPE-NAME REGEXP)
    - TYPE-NAME is a name to recognize this type
    - REGEXP is a regular expression used to recognize lines. It is evaluated with
      LOOKING-AT from the beginning of each line
 - FILTERS are the filters that can be called by the user. They are lists (NAME TYPES [KEYS])
    - NAME is the name the user passes to invoke this filter
    - TYPES is a list of type names or other filter names which is evaluated recursively
      to get the filter definition
    - KEYS is an optional list of strings giving keys to define as shortcuts for this filter
")

; These are for internal use, not customization
(defvar filter-types nil 
  "filter definitions used to partition a file in filter-minor-mode")
(defvar filter-definitions nil
  "Filters visible to the user in filter-minor-mode.")
(defvar filter-state nil 
  "Used by filter-minor-mode to hold restore information")
; First is read-only, second is modified, third is undo-list, fourth is local map

(define-minor-mode filter-minor-mode
  "Filters lines based on defined line classifications"
  nil "-FLTR"
  nil
  (if filter-minor-mode
	  (let ((filters (cdr (assoc major-mode filter-modes))))
		(make-variable-buffer-local 'filter-state)
		(make-variable-buffer-local 'filter-types)
		(make-variable-buffer-local 'filter-definitions)
		(unless filters 
		  (filter-minor-mode -1)
		  (error (format "Cannot find filter definitions for mode %s" major-mode)))
		(setq filter-state (list buffer-read-only (buffer-modified-p) buffer-undo-list (current-local-map)))
		(setq filter-types (cons '(unclassified) (first filters))
			  filter-definitions (second filters)
			  buffer-invisibility-spec nil
			  buffer-undo-list t
			  buffer-read-only nil)
		(filter-classify-lines)
		(setq buffer-read-only t)
		(use-local-map (setup-filter-map (third (car filter-modes))))
		)
	(when filter-state
	  (setq buffer-read-only nil)
	  (remove-text-properties (point-min) (point-max) '(invisible filters))
	  (setq buffer-read-only (first filter-state)
			buffer-undo-list (third filter-state))
	  (set-buffer-modified-p (second filter-state))
	  (use-local-map (fourth filter-state))
	  (setf filter-state ())
	  )))

(defun filter-classify-lines (&optional from to)
  "Classifies each line according to the filter-types definitions"
  (or from (setq from (point-min)))
  (or to (setq to (point-max)))
  (remove-text-properties from to '(invisible filters))
  (flet ((classify (x) (and (second x) (looking-at (second x)) (car x))))
	(save-excursion
	  (goto-char from)
	  (while (<= (point) to)
		(let* ((types (or (remove () (mapcar 'classify filter-types))
						  '(unclassified))))
		  (filter-set types 'invisible 'filters)
		  (if (< 0 (forward-line 1)) (setq to 0)))))))

;;;
;;; Following 3 functions get, delete, and set values 
;;;
;;; Using them guarantees lines are handled as consistent units. This
;;; requires some control to make sure the ... shows up in the right
;;; place, and empty lines don't break anything.
;;;
(defun filter-get-value (filter)
  (get-text-property (max 1 (1- (line-beginning-position))) filter))

(defun filter-remove (&rest filters)
  (let ((buffer-read-only nil))
	(remove-text-properties (max 1 (1- (line-beginning-position))) (line-end-position) filters)))

(defun filter-set (types &rest filters)
  (let ((buffer-read-only nil))
	(mapcar (lambda (x) (put-text-property (max 1 (1- (line-beginning-position))) (line-end-position) x types))
			filters)))

;;;
;;; These are for handling sets of filters or types
;;;
(defun filters-flip (keep)
  "Flips a list of filters types, takes a list of types to show and returns a list of types to hide" 
  (set-difference (mapcar 'car filter-types) keep))

(defun filter-full-def (arg)
  "Evaluates filter definitions down to the basic filter types"
  (if (assoc arg filter-types) (list arg)
	(reduce 'append (mapcar 'filter-full-def (second (assoc arg filter-definitions))))))

(defun filter-find (types forward)
  "Goes to the next line which has at least one of the given set of types
Move to the preceding (following) line to get the last match"
  (beginning-of-line)
  (setq forward (if forward 1 -1))
  (while (and (not (intersection types (filter-get-value 'filters)))
			  (= 0 (forward-line forward))))
  (point))

;;; Forces an update of the screen when the invisibility spec changes
;;; The emacs functions which are supposed to do this don't
(defun filter-force-update ()
  "Neither REDISPLAY or SIT-FOR seemed to force an update, this does"
  (let ((point (point))
		(buffer-read-only nil))
	(goto-char 0)
	(insert " ")
	(delete-char -1)
	(goto-char point)))

;;
;;
;; Key functions
;;
;;

(defun setup-filter-map (filter)
  "Builds the local keymap used by filter-minor-mode"
  (let ((map (copy-keymap (current-global-map))))
    (suppress-keymap map t)
	; Define a few standard keys first, so they can be overridden
	(define-key map "s" 'filter-show-section)
	(define-key map "x" 'filter-rehide-region)
	(define-key map "q" 'filter-minor-mode)
	(define-key map "a" '(lambda () (interactive) (filter-do 'all)))
	(define-key map "f" 'filter-do)
	(mapc (lambda (x) (mapc (lambda (y) (define-key map y 'filter-key)) (third x)))
		  filter)
	; Since undo is disabled, if the buffer is changed things might break after undo is restored.
	; So, make it hard to write in the buffer
	(define-key map "\C-x\C-q" (lambda () (interactive) (message "Exit filter-mode to change file")))
	map))

;;; This uses the 3rd arg of the filter specs to decide which filter to use
(defun filter-key () 
  "Bound to a key, this invokes a filter based on which key invoked it"
  (interactive)
  (setq a (this-command-keys))
  (let ((choice (some (lambda (x) (if (member (this-command-keys) (third x)) (first x))) filter-definitions)))
	(setq b choice)
	(and choice (filter-do choice))))

(defun filter-do (&optional type)
  "Hides all lines which do not match a given filter
Part of filter-minor-mode"
  (interactive)
  (if (eq type 'all)
	  (setq buffer-invisibility-spec nil)
	(or type (setq type (intern (completing-read "Show type: " (cons '(all) filter-definitions) nil t))))
	(setq buffer-invisibility-spec (filters-flip (filter-full-def type)))
	(if filter... 
		(setq buffer-invisibility-spec (mapcar (lambda (x) (cons x t)) buffer-invisibility-spec))))
  (beginning-of-line)
  (filter-force-update))

(defun filter-rehide (&optional from to)
  "replaces the invisible filter value in region"
  (save-excursion
	(let ((buffer-invisibility-spec nil))
	  (goto-char (or from (point-min)))
	  (or to (setq to (point-max)))
	  (while (<= (line-end-position) to)
		(filter-set (filter-get-value 'filters) 'invisible)
		(or (= 0 (forward-line)) (setq to 0))
		))))
  
(defun filter-rehide-region ()
  "Hides contiguous sections of code redisplayed in filter mode"
  (interactive)
  (unless (filter-get-value 'invisible)
	(filter-rehide (previous-single-property-change (point) 'invisible)
				   (next-single-property-change (point) 'invisible))))

;;; This is just for foxpro, but the idea will work for anything
(defun filter-show-section ()
  "Shows a section of code. Use FILTER-REHIDE-SECTION to close"
  (interactive)
  (beginning-of-line)
  (let* ((buffer-invisibility-spec nil)
		 (definition-point (or (re-search-forward (concat "^\\(\\(" (second (assoc 'toplevel-def filter-types))
														  "\\)\\|\\(" (second (assoc 'sublevel-def filter-types)) "\\)\\)") nil t)
							   (goto-char (point-max))))
		 (top-level (match-string 2))
		 (start (progn (forward-line -1) (filter-find (filters-flip (list 'empty (if top-level 'toplevel-comment 'sublevel-comment))) nil)))
		 (end (progn (goto-char definition-point)
					 (forward-line 1)
					 (filter-find (if top-level '(toplevel-comment toplevel-def)
									'(toplevel-comment toplevel-def sublevel-comment sublevel-def)) t))))
	(goto-char start)
	(forward-line)
	(while (> end (point))
	  (filter-remove 'invisible)
	  (forward-line))
	(goto-char definition-point)))

(provide 'filters)