code.delx.au - gnu-emacs-elpa/blob - packages/loccur/loccur.el

   1 ;;; loccur.el --- Perform an occur-like folding in current buffer -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2009-2016 Free Software Foundation, Inc
   4 ;;
   5 ;; Author: Alexey Veretennikov <alexey.veretennikov@gmail.com>
   6 ;;
   7 ;; Created: 2009-09-08
   8 ;; Version: 1.2.2
   9 ;; Package-Requires: ((cl-lib "0"))
  10 ;; Keywords: matching
  11 ;; URL: https://github.com/fourier/loccur
  12 ;; Compatibility: GNU Emacs 23.x, GNU Emacs 24.x
  13 ;;
  14 ;; This file is part of GNU Emacs.
  15 ;;
  16 ;; GNU Emacs is free software: you can redistribute it and/or modify
  17 ;; it under the terms of the GNU General Public License as published by
  18 ;; the Free Software Foundation, either version 3 of the License, or
  19 ;; (at your option) any later version.
  20 ;;
  21 ;; GNU Emacs is distributed in the hope that it will be useful,
  22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 ;; GNU General Public License for more details.
  25 ;;
  26 ;; You should have received a copy of the GNU General Public License
  27 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  28 ;;
  29 ;;; Commentary:
  30 ;;
  31 ;; Add the following to your .emacs file:
  32 ;;
  33 ;; (require 'loccur)
  34 ;; ;; defines shortcut for loccur of the current word
  35 ;; (define-key global-map [(control o)] 'loccur-current)
  36 ;; ;; defines shortcut for the interactive loccur command
  37 ;; (define-key global-map [(control meta o)] 'loccur)
  38 ;; ;; defines shortcut for the loccur of the previously found word
  39 ;; (define-key global-map [(control shift o)] 'loccur-previous-match)
  40 ;;
  41 ;;; Issues:
  42 ;; Using with smooth-scrolling.el sometimes
  43 ;; gives unexpected jumps in loccur mode
  44 ;;
  45 ;;; TODO:
  46 ;;
  47 ;;; Change Log:
  48 ;;
  49 ;; 2015-12-27 (1.2.2)
  50 ;;    + Preparation for GNU ELPA submission. Removed contributions
  51 ;;    without signed papers
  52 ;;    + added loccur-face - face to highlight text, by default isearch
  53 ;;
  54 ;; 2013-10-22 (1.2.1)
  55 ;;    + Added custom option loccur-jump-beginning-of-line; removed some
  56 ;;    of cl dependencies
  57 ;;
  58 ;; 2010-03-07 (1.1.1)
  59 ;;    + Default value is taken from prompt instead of an edit area
  60 ;;    (thanks to Nathaniel Flath)
  61 ;;
  62 ;; 2009-10-05 (1.1.0)
  63 ;;    + Added highlighting of the matched strings
  64 ;;    + Now inserts selected region to the prompt
  65 ;;    + Added defun for applying last found regexp(loccur-previous-match)
  66 ;;    + Added intangible property together with invisibility
  67 ;;
  68 ;; 2009-09-08 (1.0.0)
  69 ;;    Initial Release.
  70 ;;
  71 ;;; Code:
  72
  73 (require 'cl-lib)
  74
  75 (defgroup loccur nil
  76   "Perform an occur-like folding in current buffer."
  77   :group 'tools)
  78
  79 ;; should be defined before define-minor-mode
  80 (defvar loccur-mode-map
  81   (let ((map (make-sparse-keymap)))
  82     (define-key map (kbd "RET") '(lambda () (interactive) (loccur nil)))
  83     ;; redefine Ctrl+Up/Down to Up/Down, since it looks like some problem
  84     ;; with backward-paragraph and forward-paragraph with invisible overlays
  85     (define-key map (kbd "<C-up>") 'previous-line)
  86     (define-key map (kbd "<C-down>") 'next-line)
  87     map)
  88   "Keymap for the variable `loccur-mode'.")
  89
  90 ;;;###autoload
  91 (define-minor-mode loccur-mode
  92   "Minor mode for navigating through the file.
  93 Hides all lines without matches like `occur' does, but without opening
  94 a new window."
  95   :lighter " loccur"
  96   (if loccur-mode
  97       (loccur-1 loccur-current-search)
  98     (loccur-remove-overlays)
  99     (recenter)))
 100
 101 (defface loccur-face
 102   '((t (:inherit isearch)))
 103   "Loccur face")
 104
 105
 106 (defconst loccur-overlay-invisible-property-name 'loccur-invisible-overlay
 107   "Property name of the overlay for all invisible text.")
 108
 109 (defconst loccur-overlay-visible-property-name 'loccur-visible-overlay
 110   "Property name of the overlay for all visible text.")
 111
 112 (defcustom loccur-jump-beginning-of-line nil
 113   "Set cursor to the beginning of the line when the loccur function is called.
 114 Default: nil"
 115   :type '(boolean)
 116   :group 'loccur)
 117
 118 (defcustom loccur-highlight-matching-regexp t
 119   "If set to nil, do not highlight matching words.
 120 Default: t"
 121   :type '(boolean)
 122   :group 'loccur)
 123
 124 (defvar loccur-history nil
 125   "History of previously searched expressions for the prompt.")
 126
 127 (defvar-local loccur-last-match nil
 128   "Last match found.")
 129
 130 (defvar-local loccur-overlay-list nil
 131   "A list of currently active overlays.")
 132
 133 (defvar-local loccur-current-search nil
 134   "The expression to search in the current active mode.")
 135
 136 (defun loccur-current ()
 137   "Call `loccur' for the current word."
 138   (interactive)
 139   (loccur (current-word)))
 140
 141
 142 (defun loccur-previous-match ()
 143   "Call `loccur' for the previously found word."
 144   (interactive)
 145   (loccur loccur-last-match))
 146
 147 (defun loccur-no-highlight (regex)
 148   "Perform search like loccur, but temporary removing match highlight.
 149 REGEX is regexp to search"
 150   (interactive
 151    (if loccur-mode
 152        nil
 153      (list (read-string "Loccur: " (loccur-prompt) 'loccur-history))))
 154   (let ((loccur-highlight-matching-regexp nil))
 155     (loccur regex)))
 156
 157 (defun loccur-toggle-highlight ()
 158   "Toggle the highlighting of the match."
 159   (interactive)
 160   (setq loccur-highlight-matching-regexp (not loccur-highlight-matching-regexp))
 161   (when loccur-mode
 162     (dolist (ovl loccur-overlay-list)
 163       (when (overlay-get ovl loccur-overlay-visible-property-name)
 164         (overlay-put ovl 'face (if loccur-highlight-matching-regexp 'loccur-face nil))))))
 165
 166 (defun loccur (regex)
 167   "Perform a simple grep in current buffer.
 168
 169 This command hides all lines from the current buffer except those
 170 containing the regular expression REGEX.  A second call of the function
 171 unhides lines again"
 172   (interactive
 173    (if loccur-mode
 174        (list nil)
 175      (list (read-string "Loccur: " (loccur-prompt) 'loccur-history))))
 176   (if (or loccur-mode
 177           (= (length regex) 0))
 178       (progn
 179         ;; remove current search and turn off loccur mode
 180         ;; to allow to call `loccur' multiple times
 181         (setf loccur-current-search nil)
 182         (loccur-mode 0))
 183     ;; otherwise do as usual
 184     ;; if the regex argument is not equal to previous search
 185     (when (not (string-equal regex loccur-current-search))
 186       (cl-pushnew regex loccur-history)
 187       (setf loccur-current-search regex)
 188       (loccur-mode)
 189       (when loccur-jump-beginning-of-line
 190         (beginning-of-line))))) ; optionally jump to the beginning of line
 191
 192
 193 (defun loccur-prompt ()
 194   "Return the default value of the prompt.
 195
 196 Default value for prompt is a current word or active region(selection),
 197 if its size is 1 line"
 198   (let ((prompt
 199          (if (and transient-mark-mode
 200                   mark-active)
 201              (let ((pos1 (region-beginning))
 202                    (pos2 (region-end)))
 203                ;; Check if the start and the end of an active region is on
 204                ;; the same line
 205                (when (save-excursion
 206                        (goto-char pos1)
 207                        (<= pos2 (line-end-position)))
 208                    (buffer-substring-no-properties pos1 pos2)))
 209            (current-word))))
 210     prompt))
 211
 212
 213 (defun loccur-1 (regex)
 214   "Implementation of the `loccur' functionality.
 215
 216 REGEX is an argument to `loccur'."
 217   (let* ((buffer-matches (loccur-find-matches regex))
 218          (ovl-bounds (loccur-create-overlay-bounds-btw-lines buffer-matches)))
 219     (setq loccur-overlay-list
 220           (loccur-create-invisible-overlays ovl-bounds))
 221
 222     (setq loccur-overlay-list
 223           (append loccur-overlay-list
 224                   (loccur-create-highlighted-overlays buffer-matches)))
 225     (setq loccur-last-match regex)
 226     (recenter)))
 227
 228 (defun loccur-create-highlighted-overlays (buffer-matches)
 229   "Create the list of overlays for BUFFER-MATCHES."
 230   (let ((overlays
 231          (mapcar (lambda (match)
 232                    (make-overlay
 233                     (nth 1 match)
 234                     (nth 2 match)
 235                     (current-buffer) t nil))
 236                  buffer-matches)))
 237     (mapc (lambda (ovl)
 238             (overlay-put ovl loccur-overlay-visible-property-name t)
 239             (when loccur-highlight-matching-regexp
 240               (overlay-put ovl 'face 'loccur-face)))
 241           overlays)))
 242
 243
 244 (defun loccur-create-invisible-overlays (ovl-bounds)
 245   "Create a list of invisible overlays by given OVL-BOUNDS."
 246   (let ((overlays
 247          (mapcar (lambda (bnd)
 248                    (make-overlay
 249                     (car bnd)
 250                     (cadr bnd)
 251                     (current-buffer) t nil))
 252                  ovl-bounds)))
 253     (mapc (lambda (ovl)
 254             (overlay-put ovl loccur-overlay-invisible-property-name t)
 255             (overlay-put ovl 'invisible t)
 256             ;; force intangible property if invisible property
 257             ;; does not automatically set it
 258             (overlay-put ovl 'intangible t))
 259           overlays)))
 260
 261
 262 (defun loccur-remove-overlays ()
 263   "Remove all overlays."
 264   (remove-overlays (point-min) (point-max) loccur-overlay-visible-property-name t)
 265   (remove-overlays (point-min) (point-max) loccur-overlay-invisible-property-name t)
 266   (setq loccur-overlay-list nil))
 267
 268
 269 (defun loccur-create-overlay-bounds-btw-lines (buffer-matches)
 270   "Create a list of overlays between matched lines BUFFER-MATCHES."
 271   (let ((prev-end (point-min))
 272         (overlays (list)))
 273     (when buffer-matches
 274       (mapc (lambda (line)
 275               (let ((beginning (car line)))
 276                 (unless ( = (- beginning prev-end) 1)
 277                   (let ((ovl-end  (1- beginning)))
 278                     (push (list prev-end ovl-end) overlays)))
 279                 (setq prev-end (nth 3 line))))
 280             buffer-matches)
 281       (push (list (1+ prev-end) (point-max)) overlays)
 282       (setq overlays (nreverse overlays)))))
 283
 284
 285 (defun loccur-find-matches (regex)
 286   "Find all occurences in the current buffer for given REGEX.
 287
 288 Returns a list of 4-number tuples, specifying begnning of the line,
 289 1st match begin of a line, 1st match end of a line, end of a line
 290 containing match"
 291   (save-excursion
 292     ;; Go to the beginnig of buffer
 293     (goto-char (point-min))
 294     ;; Set initial values for variables
 295     (let ((endpoint nil)
 296           (lines (list)))
 297       ;; Search loop
 298       (while (not (eobp))
 299         ;; if something found
 300         (when (setq endpoint (re-search-forward regex nil t))
 301           (save-excursion
 302             (let ((found-begin (match-beginning 0))
 303                   (found-end (match-end 0)))
 304               ;; Get the start and the and of the matching line
 305               ;; and store it to the overlays array
 306               (goto-char found-begin)
 307               (setq endpoint (line-end-position))
 308               (push (list (line-beginning-position)
 309                           found-begin
 310                           found-end
 311                           endpoint) lines)))
 312           ;; maybe add some code to highlight matches like in occur-mode?
 313           ;; goto the end of line for any case
 314           (goto-char endpoint))
 315         (forward-line 1))
 316       (setq lines (nreverse lines)))))
 317
 318
 319
 320
 321
 322 (provide 'loccur)
 323 ;;; loccur.el ends here