/loccur

Permalink
Switch branches/tags
Nothing to show
Find file Copy path
0e32345 Dec 26, 2016
4 contributors

Users who have contributed to this file
@fourier @picarresursix @mookid @syohex
Raw Blame History
336 lines (290 sloc) 11.1 KB
;;; loccur.el --- Perform an occur-like folding in current buffer -*- lexical-binding: t; -*-
;; Copyright (C) 2009-2016 Free Software Foundation, Inc
;;
;; Author: Alexey Veretennikov <alexey.veretennikov@gmail.com>
;;
;; Created: 2009-09-08
;; Version: 1.2.3
;; Package-Requires: ((emacs "24.3"))
;; Keywords: matching
;; URL: https://github.com/fourier/loccur
;; Compatibility: GNU Emacs 24.3
;;
;; This file is part of GNU Emacs.
;;
;; GNU Emacs 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.
;;
;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;
;;; Commentary:
;;
;; Add the following to your .emacs file:
;;
;; (require 'loccur)
;; ;; defines shortcut for loccur of the current word
;; (define-key global-map [(control o)] 'loccur-current)
;; ;; defines shortcut for the interactive loccur command
;; (define-key global-map [(control meta o)] 'loccur)
;; ;; defines shortcut for the loccur of the previously found word
;; (define-key global-map [(control shift o)] 'loccur-previous-match)
;;
;;; Issues:
;; Using with smooth-scrolling.el sometimes
;; gives unexpected jumps in loccur mode
;;
;;; TODO:
;;
;;; Change Log:
;;
;; 2016-12-26 (1.2.3)
;; + Removed empty line in the beginning of the buffer.
;; + Added 'Tips and tricks' session to the README.md file
;; 2015-12-27 (1.2.2)
;; + Preparation for GNU ELPA submission. Removed contributions
;; without signed papers
;; + added loccur-face - face to highlight text, by default isearch
;;
;; 2013-10-22 (1.2.1)
;; + Added custom option loccur-jump-beginning-of-line; removed some
;; of cl dependencies
;;
;; 2010-03-07 (1.1.1)
;; + Default value is taken from prompt instead of an edit area
;; (thanks to Nathaniel Flath)
;;
;; 2009-10-05 (1.1.0)
;; + Added highlighting of the matched strings
;; + Now inserts selected region to the prompt
;; + Added defun for applying last found regexp(loccur-previous-match)
;; + Added intangible property together with invisibility
;;
;; 2009-09-08 (1.0.0)
;; Initial Release.
;;
;;; Code:
(require 'cl-lib)
(defgroup loccur nil
"Perform an occur-like folding in current buffer."
:group 'tools)
;; should be defined before define-minor-mode
(defvar loccur-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "RET") '(lambda () (interactive) (loccur nil)))
;; redefine Ctrl+Up/Down to Up/Down, since it looks like some problem
;; with backward-paragraph and forward-paragraph with invisible overlays
(define-key map (kbd "<C-up>") 'previous-line)
(define-key map (kbd "<C-down>") 'next-line)
map)
"Keymap for the variable `loccur-mode'.")
;;;###autoload
(define-minor-mode loccur-mode
"Minor mode for navigating through the file.
Hides all lines without matches like `occur' does, but without opening
a new window."
:lighter " loccur"
(if loccur-mode
(loccur-1 loccur-current-search)
(loccur-remove-overlays)
(recenter)))
(defface loccur-face
'((t (:inherit isearch)))
"Loccur face")
(defconst loccur-overlay-invisible-property-name 'loccur-invisible-overlay
"Property name of the overlay for all invisible text.")
(defconst loccur-overlay-visible-property-name 'loccur-visible-overlay
"Property name of the overlay for all visible text.")
(defcustom loccur-jump-beginning-of-line nil
"Set cursor to the beginning of the line when the loccur function is called.
Default: nil"
:type '(boolean)
:group 'loccur)
(defcustom loccur-highlight-matching-regexp t
"If set to nil, do not highlight matching words.
Default: t"
:type '(boolean)
:group 'loccur)
(defvar loccur-history nil
"History of previously searched expressions for the prompt.")
(defvar-local loccur-last-match nil
"Last match found.")
(defvar-local loccur-overlay-list nil
"A list of currently active overlays.")
(defvar-local loccur-current-search nil
"The expression to search in the current active mode.")
(defun loccur-current ()
"Call `loccur' for the current word."
(interactive)
(loccur (current-word)))
(defun loccur-previous-match ()
"Call `loccur' for the previously found word."
(interactive)
(loccur loccur-last-match))
(defun loccur-no-highlight (regex)
"Perform search like loccur, but temporary removing match highlight.
REGEX is regexp to search"
(interactive
(if loccur-mode
nil
(list (read-string "Loccur: " (loccur-prompt) 'loccur-history))))
(let ((loccur-highlight-matching-regexp nil))
(loccur regex)))
(defun loccur-toggle-highlight ()
"Toggle the highlighting of the match."
(interactive)
(setq loccur-highlight-matching-regexp (not loccur-highlight-matching-regexp))
(when loccur-mode
(dolist (ovl loccur-overlay-list)
(when (overlay-get ovl loccur-overlay-visible-property-name)
(overlay-put ovl 'face (if loccur-highlight-matching-regexp 'loccur-face nil))))))
(defun loccur (regex)
"Perform a simple grep in current buffer.
This command hides all lines from the current buffer except those
containing the regular expression REGEX. A second call of the function
unhides lines again.
When called interactively, either prompts the user for REGEXP or,
when called with an active region, uses the content of the
region."
(interactive
(cond ((region-active-p)
(list (buffer-substring (mark) (point))))
(loccur-mode
(list nil))
(t
(list (read-string "Loccur: " (loccur-prompt) 'loccur-history)))))
(when (region-active-p) (deactivate-mark))
(if (or loccur-mode
(= (length regex) 0))
(progn
;; remove current search and turn off loccur mode
;; to allow to call `loccur' multiple times
(setf loccur-current-search nil)
(loccur-mode 0))
;; otherwise do as usual
;; if the regex argument is not equal to previous search
(when (not (string-equal regex loccur-current-search))
(cl-pushnew regex loccur-history)
(setf loccur-current-search regex)
(loccur-mode)
(when loccur-jump-beginning-of-line
(beginning-of-line))))) ; optionally jump to the beginning of line
(defun loccur-prompt ()
"Return the default value of the prompt.
Default value for prompt is a current word or active region(selection),
if its size is 1 line"
(let ((prompt
(if (and transient-mark-mode
mark-active)
(let ((pos1 (region-beginning))
(pos2 (region-end)))
;; Check if the start and the end of an active region is on
;; the same line
(when (save-excursion
(goto-char pos1)
(<= pos2 (line-end-position)))
(buffer-substring-no-properties pos1 pos2)))
(current-word))))
prompt))
(defun loccur-1 (regex)
"Implementation of the `loccur' functionality.
REGEX is an argument to `loccur'."
(let* ((buffer-matches (loccur-find-matches regex))
(ovl-bounds (loccur-create-overlay-bounds-btw-lines buffer-matches)))
(setq loccur-overlay-list
(loccur-create-invisible-overlays ovl-bounds))
(setq loccur-overlay-list
(append loccur-overlay-list
(loccur-create-highlighted-overlays buffer-matches)))
(setq loccur-last-match regex)
(recenter)))
(defun loccur-create-highlighted-overlays (buffer-matches)
"Create the list of overlays for BUFFER-MATCHES."
(let ((overlays
(mapcar (lambda (match)
(make-overlay
(nth 1 match)
(nth 2 match)
(current-buffer) t nil))
buffer-matches)))
(mapc (lambda (ovl)
(overlay-put ovl loccur-overlay-visible-property-name t)
(when loccur-highlight-matching-regexp
(overlay-put ovl 'face 'loccur-face)))
overlays)))
(defun loccur-create-invisible-overlays (ovl-bounds)
"Create a list of invisible overlays by given OVL-BOUNDS."
(let ((overlays
(mapcar (lambda (bnd)
(make-overlay
(car bnd)
(cadr bnd)
(current-buffer) t nil))
ovl-bounds)))
(mapc (lambda (ovl)
(overlay-put ovl loccur-overlay-invisible-property-name t)
(overlay-put ovl 'invisible t)
;; force intangible property if invisible property
;; does not automatically set it
(overlay-put ovl 'intangible t))
overlays)))
(defun loccur-remove-overlays ()
"Remove all overlays."
(remove-overlays (point-min) (point-max) loccur-overlay-visible-property-name t)
(remove-overlays (point-min) (point-max) loccur-overlay-invisible-property-name t)
(setq loccur-overlay-list nil))
(defun loccur-create-overlay-bounds-btw-lines (buffer-matches)
"Create a list of overlays between matched lines BUFFER-MATCHES."
(let ((prev-end (point-min))
(overlays (list)))
(when buffer-matches
(push (list 1 (caar buffer-matches)) overlays)
(mapc (lambda (line)
(let ((beginning (car line)))
(unless ( = (- beginning prev-end) 1)
(let ((ovl-end (1- beginning)))
(push (list prev-end ovl-end) overlays)))
(setq prev-end (nth 3 line))))
buffer-matches)
(push (list (1+ prev-end) (point-max)) overlays)
(setq overlays (nreverse overlays)))))
(defun loccur-find-matches (regex)
"Find all occurences in the current buffer for given REGEX.
Returns a list of 4-number tuples, specifying begnning of the line,
1st match begin of a line, 1st match end of a line, end of a line
containing match"
(save-excursion
;; Go to the beginnig of buffer
(goto-char (point-min))
;; Set initial values for variables
(let ((endpoint nil)
(lines (list)))
;; Search loop
(while (not (eobp))
;; if something found
(when (setq endpoint (re-search-forward regex nil t))
(save-excursion
(let ((found-begin (match-beginning 0))
(found-end (match-end 0)))
;; Get the start and the and of the matching line
;; and store it to the overlays array
(goto-char found-begin)
(setq endpoint (line-end-position))
(push (list (line-beginning-position)
found-begin
found-end
endpoint) lines)))
;; maybe add some code to highlight matches like in occur-mode?
;; goto the end of line for any case
(goto-char endpoint))
(forward-line 1))
(setq lines (nreverse lines)))))
(provide 'loccur)
;;; loccur.el ends here