;;; fold-this.el --- Just fold this region please ;; Copyright (C) 2012-2013 Magnar Sveen ;; Author: Magnar Sveen ;; Version: 0.3.0 ;; Keywords: convenience ;; 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 3 ;; of the License, 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. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; Just fold the active region, please. ;; ;; ## How it works ;; ;; The command `fold-this` visually replaces the current region with `...`. ;; If you move point into the ellipsis and press enter or `C-g` it is unfolded. ;; ;; You can unfold everything with `fold-this-unfold-all`. ;; ;; You can fold all instances of the text in the region with `fold-this-all`. ;; ;; ## Setup ;; ;; I won't presume to know which keys you want these functions bound to, ;; so you'll have to set that up for yourself. Here's some example code, ;; which incidentally is what I use: ;; ;; (global-set-key (kbd "C-c C-f") 'fold-this-all) ;; (global-set-key (kbd "C-c C-F") 'fold-this) ;; (global-set-key (kbd "C-c M-f") 'fold-this-unfold-all) ;;; Code: (defvar fold-this-keymap (make-sparse-keymap)) (define-key fold-this-keymap (kbd "") 'fold-this-unfold-at-point) (define-key fold-this-keymap (kbd "C-g") 'fold-this-unfold-at-point) (defface fold-this-overlay '((t (:inherit default))) "Face used to highlight the fold overlay." :group 'fold-this) (defcustom fold-this-persistent-folds nil "Non-nil means that folds survive between buffer kills and Emacs sessions." :group 'fold-this :type 'boolean) (defcustom fold-this-persistent-folds-file (locate-user-emacs-file ".fold-this.el") "A file to save persistent fold info to." :group 'fold-this :type 'file) (defcustom fold-this-persistent-folded-file-limit 30 "A max number of files for which folds persist. Nil for no limit." :group 'fold-this :type '(choice (integer :tag "Entries" :value 1) (const :tag "No Limit" nil))) ;;;###autoload (defun fold-this (beg end) (interactive "r") (let ((o (make-overlay beg end nil t nil))) (overlay-put o 'type 'fold-this) (overlay-put o 'invisible t) (overlay-put o 'keymap fold-this-keymap) (overlay-put o 'face 'fold-this-overlay) (overlay-put o 'modification-hooks '(fold-this--unfold-overlay)) (overlay-put o 'display (propertize "." 'face 'fold-this-overlay)) (overlay-put o 'before-string (propertize "." 'face 'fold-this-overlay)) (overlay-put o 'evaporate t)) (deactivate-mark)) ;;;###autoload (defun fold-this-all (beg end) (interactive "r") (let ((string (buffer-substring (region-beginning) (region-end)))) (save-excursion (goto-char (point-min)) (while (search-forward string (point-max) t) (fold-this (match-beginning 0) (match-end 0))))) (deactivate-mark)) ;;;###autoload (defun fold-active-region (beg end) (interactive "r") (when (region-active-p) (fold-this beg end))) ;;;###autoload (defun fold-active-region-all (beg end) (interactive "r") (when (region-active-p) (fold-this-all beg end))) ;;;###autoload (defun fold-this-unfold-all () (interactive) (mapc 'fold-this--delete-my-overlay (overlays-in (point-min) (point-max)))) ;;;###autoload (defun fold-this-unfold-at-point () (interactive) (mapc 'fold-this--delete-my-overlay (overlays-at (point)))) (defun fold-this--delete-my-overlay (it) (when (eq (overlay-get it 'type) 'fold-this) (delete-overlay it))) (defun fold-this--unfold-overlay (overlay after? beg end &optional length) (delete-overlay overlay)) ;;; Fold-this overlay persistence ;; (defvar fold-this--overlay-alist nil "An alist of filenames mapped to fold overlay positions") (defvar fold-this--overlay-alist-loaded nil "Non-nil if the alist has already been loaded") (defun fold-this--find-file-hook () "A hook restoring fold overlays" (when (and fold-this-persistent-folds buffer-file-name (not (derived-mode-p 'dired-mode))) (when (not fold-this--overlay-alist-loaded) (fold-this--load-alist-from-file) (setq fold-this--overlay-alist-loaded t)) (let* ((file-name buffer-file-name) (cell (assoc file-name fold-this--overlay-alist))) (when cell (mapc (lambda (pair) (fold-this (car pair) (cdr pair))) (cdr cell)) (setq fold-this--overlay-alist (delq cell fold-this--overlay-alist)))))) (add-hook 'find-file-hook 'fold-this--find-file-hook) (defun fold-this--kill-buffer-hook () "A hook saving overlays" (when (and fold-this-persistent-folds buffer-file-name (not (derived-mode-p 'dired-mode))) (when (not fold-this--overlay-alist-loaded) (fold-this--load-alist-from-file) (setq fold-this--overlay-alist-loaded t)) (mapc 'fold-this--save-overlay-to-alist (overlays-in (point-min) (point-max))))) (add-hook 'kill-buffer-hook 'fold-this--kill-buffer-hook) (defun fold-this--kill-emacs-hook () "A hook saving overlays in all buffers and dumping them into a file" (when (and fold-this-persistent-folds fold-this--overlay-alist-loaded) (fold-this--walk-buffers-save-overlays) (fold-this--save-alist-to-file))) (add-hook 'kill-emacs-hook 'fold-this--kill-emacs-hook) (defun fold-this--save-alist-to-file () (fold-this--clean-unreadable-files) (when fold-this-persistent-folded-file-limit (fold-this--check-fold-limit)) (let ((file (expand-file-name fold-this-persistent-folds-file)) (coding-system-for-write 'utf-8) (version-control 'never)) (with-current-buffer (get-buffer-create " *Fold-this*") (delete-region (point-min) (point-max)) (insert (format ";;; -*- coding: %s -*-\n" (symbol-name coding-system-for-write))) (let ((print-length nil) (print-level nil)) (pp fold-this--overlay-alist (current-buffer))) (let ((version-control 'never)) (condition-case nil (write-region (point-min) (point-max) file) (file-error (message "Fold-this: can't write %s" file))) (kill-buffer (current-buffer)))))) (defun fold-this--load-alist-from-file () (progn (let ((file (expand-file-name fold-this-persistent-folds-file))) (when (file-readable-p file) (with-current-buffer (get-buffer-create " *Fold-this*") (delete-region (point-min) (point-max)) (insert-file-contents file) (goto-char (point-min)) (setq fold-this--overlay-alist (with-demoted-errors "Error reading fold-this-persistent-folds-file %S" (car (read-from-string (buffer-substring (point-min) (point-max)))))) (kill-buffer (current-buffer)))) nil))) (defun fold-this--walk-buffers-save-overlays () "Walk the buffer list, save overlays to the alist" (let ((buf-list (buffer-list))) (while buf-list (with-current-buffer (car buf-list) (when (and buffer-file-name (not (derived-mode-p 'dired-mode))) (mapc 'fold-this--save-overlay-to-alist (overlays-in (point-min) (point-max)))) (setq buf-list (cdr buf-list)))))) (defun fold-this--save-overlay-to-alist (overlay) "Add an overlay position pair to the alist" (when (eq (overlay-get overlay 'type) 'fold-this) (let* ((pos (cons (overlay-start overlay) (overlay-end overlay))) (file-name buffer-file-name) (cell (assoc file-name fold-this--overlay-alist)) overlay-list) (when cell (setq fold-this--overlay-alist (delq cell fold-this--overlay-alist)) (setq overlay-list (cdr cell))) (setq fold-this--overlay-alist (cons (cons file-name (cons pos overlay-list)) fold-this--overlay-alist))))) (defun fold-this--clean-unreadable-files () "Check if files in the alist exist and are readable, drop non-existing/non-readable ones" (when fold-this--overlay-alist (let ((orig fold-this--overlay-alist) new) (dolist (cell orig) (let ((fname (car cell))) (when (file-readable-p fname) (setq new (cons cell new))))) (setq fold-this--overlay-alist (nreverse new))))) (defun fold-this--check-fold-limit () "Check if there are more folds than possible, drop the tail of the alist." (when (> fold-this-persistent-folded-file-limit 0) (let ((listlen (length fold-this--overlay-alist))) (when (> listlen fold-this-persistent-folded-file-limit) (setcdr (nthcdr (1- fold-this-persistent-folded-file-limit) fold-this--overlay-alist) nil))))) (provide 'fold-this) ;;; fold-this.el ends here