code.delx.au - gnu-emacs-elpa/blob - 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 (&optional arg)
 158   "Toggle the highlighting of the match.
 159 Optional argument ARG if t turn highlight on, off otherwise."
 160   (interactive)
 161   (setq loccur-highlight-matching-regexp (not loccur-highlight-matching-regexp))
 162   (when loccur-mode
 163     (dolist (ovl loccur-overlay-list)
 164       (when (overlay-get ovl loccur-overlay-visible-property-name)
 165         (overlay-put ovl 'face (if loccur-highlight-matching-regexp 'loccur-face nil))))))
 166
 167 (defun loccur (regex)
 168   "Perform a simple grep in current buffer.
 169
 170 This command hides all lines from the current buffer except those
 171 containing the regular expression REGEX.  A second call of the function
 172 unhides lines again"
 173   (interactive
 174    (if loccur-mode
 175        (list nil)
 176      (list (read-string "Loccur: " (loccur-prompt) 'loccur-history))))
 177   (if (or loccur-mode
 178           (= (length regex) 0))
 179       (progn
 180         ;; remove current search and turn off loccur mode
 181         ;; to allow to call `loccur' multiple times
 182         (setf loccur-current-search nil)
 183         (loccur-mode 0))
 184     ;; otherwise do as usual
 185     ;; if the regex argument is not equal to previous search
 186     (when (not (string-equal regex loccur-current-search))
 187       (cl-pushnew regex loccur-history)
 188       (setf loccur-current-search regex)
 189       (loccur-mode)
 190       (when loccur-jump-beginning-of-line
 191         (beginning-of-line))))) ; optionally jump to the beginning of line
 192
 193
 194 (defun loccur-prompt ()
 195   "Return the default value of the prompt.
 196
 197 Default value for prompt is a current word or active region(selection),
 198 if its size is 1 line"
 199   (let ((prompt
 200          (if (and transient-mark-mode
 201                   mark-active)
 202              (let ((pos1 (region-beginning))
 203                    (pos2 (region-end)))
 204                ;; Check if the start and the end of an active region is on
 205                ;; the same line
 206                (when (save-excursion
 207                        (goto-char pos1)
 208                        (<= pos2 (line-end-position)))
 209                    (buffer-substring-no-properties pos1 pos2)))
 210            (current-word))))
 211     prompt))
 212
 213
 214 (defun loccur-1 (regex)
 215   "Implementation of the `loccur' functionality.
 216
 217 REGEX is an argument to `loccur'."
 218   (let* ((buffer-matches (loccur-find-matches regex))
 219          (ovl-bounds (loccur-create-overlay-bounds-btw-lines buffer-matches)))
 220     (setq loccur-overlay-list
 221           (loccur-create-invisible-overlays ovl-bounds))
 222
 223     (setq loccur-overlay-list
 224           (append loccur-overlay-list
 225                   (loccur-create-highlighted-overlays buffer-matches)))
 226     (setq loccur-last-match regex)
 227     (recenter)))
 228
 229 (defun loccur-create-highlighted-overlays (buffer-matches)
 230   "Create the list of overlays for BUFFER-MATCHES."
 231   (let ((overlays
 232          (mapcar (lambda (match)
 233                    (make-overlay
 234                     (nth 1 match)
 235                     (nth 2 match)
 236                     (current-buffer) t nil))
 237                  buffer-matches)))
 238     (mapc (lambda (ovl)
 239             (overlay-put ovl loccur-overlay-visible-property-name t)
 240             (when loccur-highlight-matching-regexp
 241               (overlay-put ovl 'face 'loccur-face)))
 242           overlays)))
 243
 244
 245 (defun loccur-create-invisible-overlays (ovl-bounds)
 246   "Create a list of invisible overlays by given OVL-BOUNDS."
 247   (let ((overlays
 248          (mapcar (lambda (bnd)
 249                    (make-overlay
 250                     (car bnd)
 251                     (cadr bnd)
 252                     (current-buffer) t nil))
 253                  ovl-bounds)))
 254     (mapc (lambda (ovl)
 255             (overlay-put ovl loccur-overlay-invisible-property-name t)
 256             (overlay-put ovl 'invisible t)
 257             ;; force intangible property if invisible property
 258             ;; does not automatically set it
 259             (overlay-put ovl 'intangible t))
 260           overlays)))
 261
 262
 263 (defun loccur-remove-overlays ()
 264   "Remove all overlays."
 265   (remove-overlays (point-min) (point-max) loccur-overlay-visible-property-name t)
 266   (remove-overlays (point-min) (point-max) loccur-overlay-invisible-property-name t)
 267   (setq loccur-overlay-list nil))
 268
 269
 270 (defun loccur-create-overlay-bounds-btw-lines (buffer-matches)
 271   "Create a list of overlays between matched lines BUFFER-MATCHES."
 272   (let ((prev-end (point-min))
 273         (overlays (list)))
 274     (when buffer-matches
 275       (mapcar (lambda (line)
 276                 (let ((beginning (car line)))
 277                   (unless ( = (- beginning prev-end) 1)
 278                     (let ((ovl-end  (1- beginning)))
 279                       (push (list prev-end ovl-end) overlays)))
 280                   (setq prev-end (nth 3 line))))
 281               buffer-matches)
 282       (push (list (1+ prev-end) (point-max)) overlays)
 283       (setq overlays (nreverse overlays)))))
 284
 285
 286 (defun loccur-find-matches (regex)
 287   "Find all occurences in the current buffer for given REGEX.
 288
 289 Returns a list of 4-number tuples, specifying begnning of the line,
 290 1st match begin of a line, 1st match end of a line, end of a line
 291 containing match"
 292   (save-excursion
 293     ;; Go to the beginnig of buffer
 294     (goto-char (point-min))
 295     ;; Set initial values for variables
 296     (let ((matches 0)
 297           (curpoint nil)
 298           (endpoint nil)
 299           (lines (list)))
 300       ;; Search loop
 301       (while (not (eobp))
 302         (setq curpoint (point))
 303         ;; if something found
 304         (when (setq endpoint (re-search-forward regex nil t))
 305           (save-excursion
 306             (let ((found-begin (match-beginning 0))
 307                   (found-end (match-end 0)))
 308               ;; Get the start and the and of the matching line
 309               ;; and store it to the overlays array
 310               (goto-char found-begin)
 311               (setq endpoint (line-end-position))
 312               (push (list (line-beginning-position)
 313                           found-begin
 314                           found-end
 315                           endpoint) lines)))
 316           ;; maybe add some code to highlight matches like in occur-mode?
 317           ;; goto the end of line for any case
 318           (goto-char endpoint))
 319         (forward-line 1))
 320       (setq lines (nreverse lines)))))
 321
 322
 323
 324
 325
 326 (provide 'loccur)
 327 ;;; loccur.el ends here