├── README.md └── fold-this.el /README.md: -------------------------------------------------------------------------------- 1 | # fold-this.el 2 | 3 | Just fold the active region, please. 4 | 5 | ## How it works 6 | 7 | The command `fold-this` visually replaces the current region with `...`. 8 | If you move point into the ellipsis and press enter or `C-g` it is unfolded. 9 | 10 | You can unfold everything with `fold-this-unfold-all`. 11 | 12 | You can fold all instances of the text in the region with `fold-this-all`. 13 | 14 | In lisp-like modes you can fold an s-expression around point with `fold-this-sexp`. 15 | 16 | ## Installation 17 | 18 | It is available on [marmalade](http://marmalade-repo.org/) and [Melpa](http://melpa.milkbox.net/): 19 | 20 | M-x package-install fold-this 21 | 22 | Or just dump it in your load path somewhere and `(require 'fold-this)` 23 | 24 | ## Setup 25 | 26 | I won't presume to know which keys you want these functions bound to, 27 | so you'll have to set that up for yourself. Here's some example code, 28 | which incidentally is what I use: 29 | 30 | ```cl 31 | (global-set-key (kbd "C-c C-f") 'fold-this-all) 32 | (global-set-key (kbd "C-c C-F") 'fold-this) 33 | (global-set-key (kbd "C-c M-f") 'fold-this-unfold-all) 34 | ``` 35 | 36 | If you want to make sure that a mistype doesn't fold anything when 37 | your region is deactivated, you can use `fold-active-region` and 38 | `fold-active-region-all` instead. 39 | 40 | You can customize the visuals of the folded region by changing 41 | `fold-this-overlay` face. 42 | 43 | ## Contributors 44 | 45 | - [Dewdrops](https://github.com/Dewdrops) contributed `fold-active-region` and `fold-active-region-all` 46 | - [Fuco1](https://github.com/Fuco1) added folded region face customization. 47 | - [Vladimir Kazanov](https://github.com/vkazanov) let folds survive buffer kills via `fold-this-persistent-folds`. 48 | 49 | ## License 50 | 51 | Copyright (C) 2012-2015 Magnar Sveen 52 | 53 | Author: Magnar Sveen 54 | Keywords: convenience 55 | 56 | This program is free software; you can redistribute it and/or modify 57 | it under the terms of the GNU General Public License as published by 58 | the Free Software Foundation, either version 3 of the License, or 59 | (at your option) any later version. 60 | 61 | This program is distributed in the hope that it will be useful, 62 | but WITHOUT ANY WARRANTY; without even the implied warranty of 63 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 64 | GNU General Public License for more details. 65 | 66 | You should have received a copy of the GNU General Public License 67 | along with this program. If not, see . 68 | -------------------------------------------------------------------------------- /fold-this.el: -------------------------------------------------------------------------------- 1 | ;;; fold-this.el --- Just fold this region please -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (C) 2012-2013 Magnar Sveen 4 | 5 | ;; Author: Magnar Sveen 6 | ;; Version: 0.4.4 7 | ;; Keywords: convenience 8 | ;; Homepage: https://github.com/magnars/fold-this.el 9 | 10 | ;; This program is free software; you can redistribute it and/or 11 | ;; modify it under the terms of the GNU General Public License 12 | ;; as published by the Free Software Foundation; either version 3 13 | ;; of the License, or (at your option) any later version. 14 | 15 | ;; This program is distributed in the hope that it will be useful, 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | ;; GNU General Public License for more details. 19 | 20 | ;; You should have received a copy of the GNU General Public License 21 | ;; along with this program. If not, see . 22 | 23 | ;;; Commentary: 24 | 25 | ;; Just fold the active region, please. 26 | ;; 27 | ;; ## How it works 28 | ;; 29 | ;; The command `fold-this` visually replaces the current region with `[[…]]`. 30 | ;; If you move point into the ellipsis and press enter or `C-g` it is unfolded. 31 | ;; 32 | ;; You can unfold everything with `fold-this-unfold-all`. 33 | ;; 34 | ;; You can fold all instances of the text in the region with `fold-this-all`. 35 | ;; 36 | ;;; Code: 37 | (require 'thingatpt) 38 | 39 | (defgroup fold-this nil 40 | "Just fold this region please." 41 | :prefix "fold-this-" 42 | :group 'languages) 43 | 44 | (defcustom fold-this-mode-key-prefix (kbd "C-c") 45 | "The prefix key for `fold-this' mode commands." 46 | :group 'fold-this 47 | :type 'sexp) 48 | 49 | (defcustom fold-this-skip-chars 0 50 | "How many chars to skip from selected when creating the overlay. 51 | Define a \"border\" to skip on overly creation." 52 | :group 'fold-this 53 | :type 'integer 54 | :package-version '(fold-this . 0.4.4)) 55 | 56 | (defvar fold-this--overlay-keymap 57 | (let ((map (make-sparse-keymap))) 58 | (define-key map (kbd "") 'fold-this-unfold-at-point) 59 | (define-key map (kbd "C-g") 'fold-this-unfold-at-point) 60 | map) 61 | "Keymap for `fold-this' but only on the overlay.") 62 | 63 | (defvar fold-this-keymap 64 | (let ((map (make-sparse-keymap))) 65 | (let ((prefix-map (make-sparse-keymap))) 66 | (define-key prefix-map (kbd "C-f") 'fold-this) 67 | (define-key prefix-map (kbd "M-C-f") 'fold-this-all) 68 | (define-key prefix-map (kbd "M-f") 'fold-this-unfold-all) 69 | (define-key map fold-this-mode-key-prefix prefix-map) 70 | map)) 71 | "Keymap for `fold-this'.") 72 | 73 | (defface fold-this-overlay 74 | '((t (:inherit default :foreground "green"))) 75 | "Face used to highlight the fold overlay." 76 | :group 'fold-this) 77 | 78 | (defcustom fold-this-overlay-text "[[…]]" 79 | "Default text for `fold-this' mode overlays." 80 | :group 'fold-this 81 | :type '(choice (string :tag "Text") 82 | (list (string :tag "Beginning text") (string :tag "Middle text") (string :tag "End text")))) 83 | 84 | (defcustom fold-this-persistent-folds nil 85 | "Should folds survive buffer kills and Emacs sessions. 86 | Non-nil means that folds should survive buffers killing and Emacs 87 | sessions. " 88 | :group 'fold-this 89 | :type 'boolean) 90 | 91 | (defcustom fold-this-persistent-folds-file (locate-user-emacs-file ".fold-this.el") 92 | "A file to save persistent fold info to." 93 | :group 'fold-this 94 | :type 'file) 95 | 96 | (defcustom fold-this-persistent-folded-file-limit 30 97 | "A max number of files for which folds persist. Nil for no limit." 98 | :group 'fold-this 99 | :type '(choice (integer :tag "Entries" :value 1) 100 | (const :tag "No Limit" nil))) 101 | 102 | ;;;###autoload 103 | (defun fold-this (beg end &optional fold-header) 104 | "Fold the region between BEG and END. 105 | 106 | If FOLD-HEADER is specified, show this text in place of the 107 | folded region. If not, default to `fold-this-overlay-text'." 108 | (interactive "r") 109 | (let* ((fold-header-text (or fold-header fold-this-overlay-text)) 110 | (fold-header (or (and (listp fold-header-text) 111 | (concat (nth 0 fold-header-text) 112 | (buffer-substring beg (+ beg fold-this-skip-chars)) 113 | (nth 1 fold-header-text) 114 | (buffer-substring (- end fold-this-skip-chars) end) 115 | (nth 2 fold-header-text))) 116 | fold-header-text)) 117 | (o (make-overlay beg end nil t nil))) 118 | (overlay-put o 'type 'fold-this) 119 | (overlay-put o 'invisible t) 120 | (overlay-put o 'keymap fold-this--overlay-keymap) 121 | (overlay-put o 'isearch-open-invisible-temporary 122 | (lambda (ov action) 123 | (if action 124 | (progn 125 | (overlay-put ov 'display (propertize fold-header 'face 'fold-this-overlay)) 126 | (overlay-put ov 'invisible t)) 127 | (progn 128 | (overlay-put ov 'display nil) 129 | (overlay-put ov 'invisible nil))))) 130 | (overlay-put o 'isearch-open-invisible 'fold-this--delete-my-overlay) 131 | (overlay-put o 'face 'fold-this-overlay) 132 | (overlay-put o 'modification-hooks '(fold-this--delete-my-overlay)) 133 | (overlay-put o 'display (propertize fold-header 'face 'fold-this-overlay)) 134 | (overlay-put o 'evaporate t)) 135 | (deactivate-mark)) 136 | 137 | ;;;###autoload 138 | (defun fold-this-sexp () 139 | "Fold sexp around point. 140 | 141 | If the point is at a symbol, fold the parent sexp. If the point 142 | is in front of a sexp, fold the following sexp." 143 | (interactive) 144 | (let* ((region 145 | (cond 146 | ((symbol-at-point) 147 | (save-excursion 148 | (when (nth 3 (syntax-ppss)) 149 | (goto-char (nth 8 (syntax-ppss)))) 150 | (backward-up-list) 151 | (cons (point) 152 | (progn 153 | (forward-sexp) 154 | (point))))) 155 | ((looking-at-p (rx (* blank) "(")) 156 | (save-excursion 157 | (skip-syntax-forward " ") 158 | (cons (point) 159 | (progn 160 | (forward-sexp) 161 | (point))))) 162 | (t nil))) 163 | (header (when region 164 | (save-excursion 165 | (goto-char (car region)) 166 | (buffer-substring (point) (line-end-position)))))) 167 | (when region 168 | (fold-this (car region) (cdr region) header)))) 169 | 170 | ;;;###autoload 171 | (defun fold-this-all (_beg _end) 172 | "Fold all occurences of text in region." 173 | (interactive "r") 174 | (let ((string (buffer-substring (region-beginning) 175 | (region-end)))) 176 | (save-excursion 177 | (goto-char (point-min)) 178 | (while (search-forward string (point-max) t) 179 | (fold-this (match-beginning 0) (match-end 0))))) 180 | (deactivate-mark)) 181 | 182 | (defun fold-active-region (beg end) 183 | (interactive "r") 184 | (when (region-active-p) 185 | (fold-this beg end))) 186 | 187 | (defun fold-active-region-all (beg end) 188 | (interactive "r") 189 | (when (region-active-p) 190 | (fold-this-all beg end))) 191 | 192 | (defun fold-this-unfold-all () 193 | "Unfold all overlays in current buffer. 194 | If narrowing is active, only in it." 195 | (interactive) 196 | (mapc 'fold-this--delete-my-overlay 197 | (overlays-in (point-min) (point-max)))) 198 | 199 | (defun fold-this-unfold-at-point () 200 | "Unfold at point." 201 | (interactive) 202 | (mapc 'fold-this--delete-my-overlay 203 | (overlays-at (point)))) 204 | 205 | (defun fold-this--delete-my-overlay (overlay &optional _after? _beg _end _length) 206 | "Delete the OVERLAY overlays only if it's an `fold-this'." 207 | (when (eq (overlay-get overlay 'type) 'fold-this) 208 | (delete-overlay overlay))) 209 | 210 | ;;; Fold-this overlay persistence 211 | ;; 212 | 213 | (defvar fold-this--overlay-alist nil 214 | "An alist of filenames mapped to fold overlay positions.") 215 | 216 | (defvar fold-this--overlay-alist-loaded nil 217 | "Non-nil if the alist has already been loaded.") 218 | 219 | (defun fold-this--find-file-hook () 220 | "A hook restoring fold overlays." 221 | (when (and fold-this-persistent-folds 222 | buffer-file-name 223 | (not (derived-mode-p 'dired-mode))) 224 | (when (not fold-this--overlay-alist-loaded) 225 | (fold-this--load-alist-from-file)) 226 | (let* ((file-name buffer-file-name) 227 | (cell (assoc file-name fold-this--overlay-alist))) 228 | (when cell 229 | (mapc (lambda (pair) (fold-this (car pair) (cdr pair))) 230 | (cdr cell)) 231 | (setq fold-this--overlay-alist 232 | (delq cell fold-this--overlay-alist)) 233 | (fold-this-mode 1))))) 234 | 235 | (defun fold-this--kill-buffer-hook () 236 | "A hook saving overlays." 237 | (when (and fold-this-persistent-folds 238 | buffer-file-name 239 | (not (derived-mode-p 'dired-mode))) 240 | (when (not fold-this--overlay-alist-loaded) 241 | ;; is it even possible ? 242 | (fold-this--load-alist-from-file)) 243 | (save-restriction 244 | (widen) 245 | (mapc 'fold-this--save-overlay-to-alist 246 | (overlays-in (point-min) (point-max)))) 247 | (when (alist-get buffer-file-name fold-this--overlay-alist) 248 | (fold-this--save-alist-to-file)))) 249 | 250 | (defun fold-this--kill-emacs-hook () 251 | "A hook saving overlays in all buffers and dumping them into a file." 252 | (when (and fold-this-persistent-folds 253 | fold-this--overlay-alist-loaded) 254 | (fold-this--walk-buffers-save-overlays) 255 | (fold-this--save-alist-to-file))) 256 | 257 | (defun fold-this--save-alist-to-file () 258 | "Save current overlay alist to file." 259 | (fold-this--clean-unreadable-files) 260 | (when fold-this-persistent-folded-file-limit 261 | (fold-this--check-fold-limit)) 262 | (let ((file (expand-file-name fold-this-persistent-folds-file)) 263 | (coding-system-for-write 'utf-8) 264 | (version-control 'never)) 265 | (with-current-buffer (get-buffer-create " *Fold-this*") 266 | (delete-region (point-min) (point-max)) 267 | (insert (format ";;; -*- coding: %s -*-\n" 268 | (symbol-name coding-system-for-write))) 269 | (let ((print-length nil) 270 | (print-level nil)) 271 | (pp fold-this--overlay-alist (current-buffer))) 272 | (let ((version-control 'never)) 273 | (condition-case nil 274 | (write-region (point-min) (point-max) file) 275 | (file-error (message "Fold-this: can't write %s" file))) 276 | (kill-buffer (current-buffer)))))) 277 | 278 | (defun fold-this--load-alist-from-file () 279 | "Restore ovelay alist `fold-this--overlay-alist' from file." 280 | (let ((file (expand-file-name fold-this-persistent-folds-file))) 281 | (when (file-readable-p file) 282 | (with-current-buffer (get-buffer-create " *Fold-this*") 283 | (delete-region (point-min) (point-max)) 284 | (insert-file-contents file) 285 | (goto-char (point-min)) 286 | (setq fold-this--overlay-alist 287 | (with-demoted-errors "Error reading fold-this-persistent-folds-file %S" 288 | (car (read-from-string 289 | (buffer-substring (point-min) (point-max)))))) 290 | (kill-buffer (current-buffer)))) 291 | (setq fold-this--overlay-alist-loaded t))) 292 | 293 | (defun fold-this--walk-buffers-save-overlays () 294 | "Walk the buffer list, save overlays to the alist." 295 | (let ((buf-list (buffer-list))) 296 | (while buf-list 297 | (with-current-buffer (car buf-list) 298 | (when (and buffer-file-name 299 | (not (derived-mode-p 'dired-mode))) 300 | (setq fold-this--overlay-alist 301 | (delq (assoc buffer-file-name fold-this--overlay-alist) 302 | fold-this--overlay-alist)) 303 | (save-restriction 304 | (widen) 305 | (mapc 'fold-this--save-overlay-to-alist 306 | (overlays-in (point-min) (point-max))))) 307 | (setq buf-list (cdr buf-list)))))) 308 | 309 | (defun fold-this--save-overlay-to-alist (overlay) 310 | "Add an OVERLAY position pair to the alist." 311 | (when (eq (overlay-get overlay 'type) 'fold-this) 312 | (let* ((pos (cons (overlay-start overlay) (overlay-end overlay))) 313 | (file-name buffer-file-name) 314 | (cell (assoc file-name fold-this--overlay-alist)) 315 | overlay-list) 316 | (unless (member pos cell) ;; only if overlay is not already there 317 | (when cell 318 | (setq fold-this--overlay-alist 319 | (delq cell fold-this--overlay-alist) 320 | overlay-list (delq pos (cdr cell)))) 321 | (setq fold-this--overlay-alist 322 | (cons (cons file-name (cons pos overlay-list)) 323 | fold-this--overlay-alist)))))) 324 | 325 | (defun fold-this--clean-unreadable-files () 326 | "Check if files in the alist exist and are readable. 327 | Drop non-existing/non-readable ones." 328 | (when fold-this--overlay-alist 329 | (let ((orig fold-this--overlay-alist) 330 | new) 331 | (dolist (cell orig) 332 | (let ((fname (car cell))) 333 | (when (file-readable-p fname) 334 | (setq new (cons cell new))))) 335 | (setq fold-this--overlay-alist 336 | (nreverse new))))) 337 | 338 | (defun fold-this--check-fold-limit () 339 | "Check if there are more folds than possible. 340 | Drop the tail of the alist." 341 | (when (> fold-this-persistent-folded-file-limit 0) 342 | (let ((listlen (length fold-this--overlay-alist))) 343 | (when (> listlen fold-this-persistent-folded-file-limit) 344 | (setcdr (nthcdr (1- fold-this-persistent-folded-file-limit) fold-this--overlay-alist) 345 | nil))))) 346 | 347 | ;;;###autoload 348 | (define-minor-mode fold-this-mode 349 | "Toggle folding on or off. 350 | With folding activated add custom map \\[fold-this-keymap]" 351 | :lighter (:eval (apply 'concat " " 352 | (if (listp fold-this-overlay-text) 353 | fold-this-overlay-text 354 | (list fold-this-overlay-text)))) 355 | :keymap fold-this-keymap 356 | :group 'fold-this 357 | :init-value nil 358 | (unless fold-this-mode 359 | (fold-this-unfold-all))) 360 | 361 | ;;;###autoload 362 | (define-minor-mode fold-this-persistent-mode 363 | "Enable persistence of overlays for `fold-this-mode'" 364 | :global t 365 | :group 'fold-this 366 | :lighter " ft-p" 367 | (if fold-this-persistent-mode 368 | (progn 369 | (unless fold-this-persistent-folds 370 | (setq fold-this-persistent-folds t)) 371 | (add-hook 'find-file-hook #'fold-this--find-file-hook) 372 | (add-hook 'kill-buffer-hook #'fold-this--kill-buffer-hook) 373 | (add-hook 'kill-emacs-hook #'fold-this--kill-emacs-hook)) 374 | (progn 375 | (setq fold-this-persistent-folds (get fold-this-persistent-folds 'standard-value)) 376 | (remove-hook 'find-file-hook 'fold-this--find-file-hook) 377 | (remove-hook 'kill-buffer-hook 'fold-this--kill-buffer-hook) 378 | (remove-hook 'kill-emacs-hook 'fold-this--kill-emacs-hook)))) 379 | 380 | (provide 'fold-this) 381 | ;;; fold-this.el ends here 382 | --------------------------------------------------------------------------------