;;; vlf-occur.el --- Occur-like functionality for VLF  -*- lexical-binding: t -*-

;; Copyright (C) 2014 Free Software Foundation, Inc.

;; Keywords: large files, indexing, occur
;; Author: Andrey Kotlarski <m00naticus@gmail.com>
;; URL: https://github.com/m00natic/vlfi

;; This file 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, or (at your option)
;; any later version.

;; This file 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; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:
;; This package provides the `vlf-occur' command which builds
;; index of search occurrences in large file just like occur.

;;; Code:

(require 'vlf)

(defvar vlf-occur-vlf-file nil "VLF file that is searched.")
(make-variable-buffer-local 'vlf-occur-vlf-file)

(defvar vlf-occur-vlf-buffer nil "VLF buffer that is scanned.")
(make-variable-buffer-local 'vlf-occur-vlf-buffer)

(defvar vlf-occur-regexp)
(make-variable-buffer-local 'vlf-occur-regexp)

(defvar vlf-occur-hexl nil "Is `hexl-mode' active?")
(make-variable-buffer-local 'vlf-occur-hexl)

(defvar vlf-occur-lines 0 "Number of lines scanned by `vlf-occur'.")
(make-variable-buffer-local 'vlf-occur-lines)

(defvar tramp-verbose)
(defvar hexl-bits)

(defvar vlf-occur-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map "n" 'vlf-occur-next-match)
    (define-key map "p" 'vlf-occur-prev-match)
    (define-key map "\C-m" 'vlf-occur-visit)
    (define-key map "\M-\r" 'vlf-occur-visit-new-buffer)
    (define-key map [mouse-1] 'vlf-occur-visit)
    (define-key map "o" 'vlf-occur-show)
    (define-key map [remap save-buffer] 'vlf-occur-save)
    map)
  "Keymap for command `vlf-occur-mode'.")

(define-derived-mode vlf-occur-mode special-mode "VLF[occur]"
  "Major mode for showing occur matches of VLF opened files."
  (add-hook 'write-file-functions 'vlf-occur-save nil t))

(defun vlf-occur-next-match ()
  "Move cursor to next match."
  (interactive)
  (if (eq (get-text-property (point) 'face) 'match)
      (goto-char (next-single-property-change (point) 'face)))
  (goto-char (or (text-property-any (point) (point-max) 'face 'match)
                 (text-property-any (point-min) (point)
                                    'face 'match))))

(defun vlf-occur-prev-match ()
  "Move cursor to previous match."
  (interactive)
  (if (eq (get-text-property (point) 'face) 'match)
      (goto-char (previous-single-property-change (point) 'face)))
  (while (not (eq (get-text-property (point) 'face) 'match))
    (goto-char (or (previous-single-property-change (point) 'face)
                   (point-max)))))

(defun vlf-occur-show (&optional event)
  "Visit current `vlf-occur' link in a vlf buffer but stay in the \
occur buffer.  If original VLF buffer has been killed,
open new VLF session each time.
EVENT may hold details of the invocation."
  (interactive (list last-nonmenu-event))
  (let ((occur-buffer (if event
                          (window-buffer (posn-window
                                          (event-end event)))
                        (current-buffer))))
    (vlf-occur-visit event)
    (pop-to-buffer occur-buffer)))

(defun vlf-occur-visit-new-buffer ()
  "Visit `vlf-occur' link in new vlf buffer."
  (interactive)
  (let ((current-prefix-arg t))
    (vlf-occur-visit)))

(defun vlf-occur-visit (&optional event)
  "Visit current `vlf-occur' link in a vlf buffer.
With prefix argument or if original VLF buffer has been killed,
open new VLF session.
EVENT may hold details of the invocation."
  (interactive (list last-nonmenu-event))
  (when event
    (set-buffer (window-buffer (posn-window (event-end event))))
    (goto-char (posn-point (event-end event))))
  (let* ((pos (point))
         (pos-relative (- pos (previous-single-char-property-change
                               pos 'vlf-match)))
         (chunk-start (get-text-property pos 'chunk-start)))
    (if chunk-start
        (let ((chunk-end (get-text-property pos 'chunk-end))
              (file (if (file-exists-p vlf-occur-vlf-file)
                        vlf-occur-vlf-file
                      (setq vlf-occur-vlf-file
                            (read-file-name
                             (concat vlf-occur-vlf-file
                                     " doesn't exist, locate it: ")))))
              (vlf-buffer vlf-occur-vlf-buffer)
              (not-hexl (not vlf-occur-hexl))
              (occur-buffer (current-buffer))
              (match-pos (+ (get-text-property pos 'line-pos)
                            pos-relative)))
          (cond (current-prefix-arg
                 (let ((original-occur-buffer vlf-occur-vlf-buffer))
                   (setq vlf-buffer (vlf file t))
                   (if (buffer-live-p original-occur-buffer)
                       (vlf-tune-copy-profile original-occur-buffer)))
                 (or not-hexl (hexl-mode))
                 (switch-to-buffer occur-buffer))
                ((not (buffer-live-p vlf-buffer))
                 (unless (catch 'found
                           (dolist (buf (buffer-list))
                             (set-buffer buf)
                             (and vlf-mode
                                  (equal file buffer-file-name)
                                  (eq (not (derived-mode-p 'hexl-mode))
                                      not-hexl)
                                  (setq vlf-buffer buf)
                                  (throw 'found t))))
                   (setq vlf-buffer (vlf file t))
                   (or not-hexl (hexl-mode)))
                 (switch-to-buffer occur-buffer)
                 (setq vlf-occur-vlf-buffer vlf-buffer)))
          (pop-to-buffer vlf-buffer)
          (vlf-move-to-chunk chunk-start chunk-end)
          (goto-char match-pos)))))

(defun vlf-occur-other-buffer (regexp)
  "Make whole file occur style index for REGEXP branching to new buffer.
Prematurely ending indexing will still show what's found so far."
  (let ((vlf-buffer (current-buffer))
        (file buffer-file-name)
        (file-size vlf-file-size)
        (batch-size vlf-batch-size)
        (is-hexl (derived-mode-p 'hexl-mode)))
    (with-temp-buffer
      (setq buffer-file-name file
            buffer-file-truename file
            buffer-undo-list t
            vlf-file-size file-size)
      (set-buffer-modified-p nil)
      (set (make-local-variable 'vlf-batch-size) batch-size)
      (when vlf-tune-enabled
        (vlf-tune-copy-profile vlf-buffer)
        (vlf-tune-batch (if is-hexl
                            '(:hexl :raw)
                          '(:insert :encode)) t))
      (vlf-mode 1)
      (if is-hexl (hexl-mode))
      (goto-char (point-min))
      (vlf-build-occur regexp vlf-buffer)
      (if vlf-tune-enabled
          (vlf-tune-copy-profile (current-buffer) vlf-buffer)))))

(defun vlf-occur (regexp)
  "Make whole file occur style index for REGEXP.
Prematurely ending indexing will still show what's found so far."
  (interactive (list (read-regexp "List lines matching regexp"
                                  (if regexp-history
                                      (car regexp-history)))))
  (run-hook-with-args 'vlf-before-batch-functions 'occur)
  (if (or (buffer-modified-p)
          (consp buffer-undo-list)
          (< vlf-batch-size vlf-start-pos))
      (vlf-occur-other-buffer regexp)
    (let ((start-pos vlf-start-pos)
          (end-pos vlf-end-pos)
          (pos (point))
          (batch-size vlf-batch-size))
      (vlf-tune-batch (if (derived-mode-p 'hexl-mode)
                          '(:hexl :raw)
                        '(:insert :encode)) t)
      (vlf-move-to-batch 0)
      (goto-char (point-min))
      (unwind-protect (vlf-build-occur regexp (current-buffer))
        (vlf-move-to-chunk start-pos end-pos)
        (goto-char pos)
        (setq vlf-batch-size batch-size))))
  (run-hook-with-args 'vlf-after-batch-functions 'occur))

(defun vlf-build-occur (regexp vlf-buffer)
  "Build occur style index for REGEXP over VLF-BUFFER."
  (let* ((tramp-verbose (if (boundp 'tramp-verbose)
                            (min tramp-verbose 1)))
         (case-fold-search t)
         (line 1)
         (last-match-line 0)
         (total-matches 0)
         (first-line-offset 0)
         (first-line-incomplete nil)
         (match-start-point (point-min))
         (match-end-point match-start-point)
         (last-match-insert-point nil)
         (occur-buffer (generate-new-buffer
                        (concat "*VLF-occur " (file-name-nondirectory
                                               buffer-file-name)
                                "*")))
         (is-hexl (derived-mode-p 'hexl-mode))
         (end-of-file nil)
         (time (float-time))
         (tune-types (if is-hexl '(:hexl :raw)
                       '(:insert :encode)))
         (reporter (make-progress-reporter
                    (concat "Building index for " regexp "...")
                    vlf-start-pos vlf-file-size)))
    (with-current-buffer occur-buffer
      (setq buffer-undo-list t))
    (unwind-protect
        (progn
          (while (not end-of-file)
            (if (re-search-forward regexp nil t)
                (progn
                  (setq line (+ line -1
                                (count-lines match-start-point
                                             (1+ (match-beginning 0))))
                        match-start-point (match-beginning 0)
                        match-end-point (match-end 0))
                  (let* ((chunk-start vlf-start-pos)
                         (chunk-end vlf-end-pos)
                         (line-pos (save-excursion
                                     (goto-char match-start-point)
                                     (line-beginning-position)))
                         (line-text (buffer-substring
                                     line-pos (line-end-position))))
                    (if (/= line-pos (point-min))
                        (setq first-line-offset 0
                              first-line-incomplete nil))
                    (with-current-buffer occur-buffer
                      (unless (= line last-match-line) ;new match line
                        (insert "\n:") ; insert line number
                        (let* ((column-point (1- (point)))
                               (overlay-pos column-point)
                               (overlay (make-overlay
                                         overlay-pos
                                         (1+ overlay-pos))))
                          (overlay-put overlay 'before-string
                                       (propertize
                                        (number-to-string line)
                                        'face 'shadow))
                          (overlay-put overlay 'vlf-match t)
                          (setq last-match-insert-point column-point
                                first-line-offset 0)))
                      (when (or first-line-incomplete
                                (/= line last-match-line))
                        (insert (propertize
                                 (if first-line-incomplete
                                     (substring line-text
                                                first-line-incomplete)
                                   line-text)
                                 'chunk-start chunk-start
                                 'chunk-end chunk-end
                                 'mouse-face '(highlight)
                                 'line-pos line-pos
                                 'help-echo
                                 (format "Move to line %d"
                                         line)))
                        (setq first-line-incomplete nil))
                      (setq last-match-line line
                            total-matches (1+ total-matches))
                      (let ((line-start (+ last-match-insert-point
                                           first-line-offset 1
                                           (- line-pos))))
                        (add-text-properties ; mark match
                         (+ line-start match-start-point)
                         (+ line-start match-end-point)
                         (list 'face 'match
                               'help-echo (format "Move to match %d"
                                                  total-matches)))))))
              (setq end-of-file (= vlf-end-pos vlf-file-size))
              (unless end-of-file
                (let ((start
                       (if is-hexl
                           (progn
                             (goto-char (point-max))
                             (forward-line -10)
                             (setq line
                                   (+ line
                                      (if (< match-end-point (point))
                                          (count-lines match-start-point
                                                       (point))
                                        (goto-char match-end-point)
                                        (1- (count-lines match-start-point
                                                         match-end-point)))))
                             (- vlf-end-pos (* (- 10 (forward-line 10))
                                               hexl-bits)))
                         (let* ((pmax (point-max))
                                (batch-step (min 1024 (/ vlf-batch-size
                                                         10)))
                                (batch-point
                                 (max match-end-point
                                      (or
                                       (byte-to-position
                                        (- vlf-batch-size batch-step))
                                       (progn
                                         (goto-char pmax)
                                         (let ((last (line-beginning-position)))
                                           (if (= last (point-min))
                                               (1- (point))
                                             last)))))))
                           (goto-char batch-point)
                           (setq first-line-offset
                                 (- batch-point (line-beginning-position))
                                 line
                                 (+ line
                                    (count-lines match-start-point
                                                 batch-point)
                                    (if (< 0 first-line-offset) -1 0)))
                           ;; last match is on the last line?
                           (goto-char match-end-point)
                           (forward-line)
                           (setq first-line-incomplete
                                 (if (= (point) pmax)
                                     (- pmax match-end-point)))
                           (vlf-byte-position batch-point)))))
                  (vlf-tune-batch tune-types)
                  (setq vlf-end-pos start) ;not to adjust start
                  (vlf-move-to-chunk start (+ start vlf-batch-size)))
                (setq match-start-point (point-min)
                      match-end-point match-start-point)
                (goto-char match-end-point)
                (progress-reporter-update reporter vlf-start-pos))))
          (progress-reporter-done reporter))
      (set-buffer-modified-p nil)
      (if (zerop total-matches)
          (progn (kill-buffer occur-buffer)
                 (message "No matches for \"%s\" (%f secs)"
                          regexp (- (float-time) time)))
        (let ((file buffer-file-name)
              (dir default-directory))
          (with-current-buffer occur-buffer
            (insert "\n")
            (goto-char (point-min))
            (insert (propertize
                     (format "%d matches from %d lines for \"%s\" \
in file: %s" total-matches line regexp file)
                     'face 'underline))
            (set-buffer-modified-p nil)
            (forward-char 2)
            (vlf-occur-mode)
            (setq default-directory dir
                  vlf-occur-vlf-file file
                  vlf-occur-vlf-buffer vlf-buffer
                  vlf-occur-regexp regexp
                  vlf-occur-hexl is-hexl
                  vlf-occur-lines line)))
        (display-buffer occur-buffer)
        (message "Occur finished for \"%s\" (%f secs)"
                 regexp (- (float-time) time))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; save, load vlf-occur data

(defun vlf-occur-save (file)
  "Serialize `vlf-occur' results to FILE which can later be reloaded."
  (interactive (list (or buffer-file-name
                         (read-file-name "Save vlf-occur results in: "
                                         nil nil nil
                                         (concat
                                          (file-name-nondirectory
                                           vlf-occur-vlf-file)
                                          ".vlfo")))))
  (setq buffer-file-name file)
  (let ((vlf-occur-save-buffer
         (generate-new-buffer (concat "*VLF-occur-save "
                                      (file-name-nondirectory file)
                                      "*"))))
    (with-current-buffer vlf-occur-save-buffer
      (setq buffer-file-name file
            buffer-undo-list t)
      (insert ";; -*- eval: (vlf-occur-load) -*-\n"))
    (prin1 (list vlf-occur-vlf-file vlf-occur-regexp vlf-occur-hexl
                 vlf-occur-lines)
           vlf-occur-save-buffer)
    (save-excursion
      (goto-char (point-min))
      (let ((pmax (point-max)))
        (while (/= pmax (goto-char (next-single-char-property-change
                                    (1+ (point)) 'vlf-match)))
          (let* ((pos (1+ (point)))
                 (line (get-char-property (1- pos) 'before-string)))
            (if line
                (prin1 (list (string-to-number line)
                             (get-text-property pos 'chunk-start)
                             (get-text-property pos 'chunk-end)
                             (get-text-property pos 'line-pos)
                             (buffer-substring-no-properties
                              pos (1- (next-single-char-property-change
                                       pos 'vlf-match))))
                       vlf-occur-save-buffer))))))
    (with-current-buffer vlf-occur-save-buffer
      (save-buffer))
    (kill-buffer vlf-occur-save-buffer))
  t)

;;;###autoload
(defun vlf-occur-load ()
  "Load serialized `vlf-occur' results from current buffer."
  (interactive)
  (goto-char (point-min))
  (let* ((vlf-occur-data-buffer (current-buffer))
         (header (read vlf-occur-data-buffer))
         (vlf-file (nth 0 header))
         (regexp (nth 1 header))
         (all-lines (nth 3 header))
         (file buffer-file-name)
         (vlf-occur-buffer
          (generate-new-buffer (concat "*VLF-occur "
                                       (file-name-nondirectory file)
                                       "*"))))
    (switch-to-buffer vlf-occur-buffer)
    (setq buffer-file-name file
          buffer-undo-list t)
    (goto-char (point-min))
    (let ((match-count 0)
          (form 0))
      (while (setq form (ignore-errors (read vlf-occur-data-buffer)))
        (goto-char (point-max))
        (insert "\n:")
        (let* ((overlay-pos (1- (point)))
               (overlay (make-overlay overlay-pos (1+ overlay-pos)))
               (line (number-to-string (nth 0 form)))
               (pos (point)))
          (overlay-put overlay 'before-string
                       (propertize line 'face 'shadow))
          (overlay-put overlay 'vlf-match t)
          (insert (propertize (nth 4 form) 'chunk-start (nth 1 form)
                              'chunk-end (nth 2 form)
                              'mouse-face '(highlight)
                              'line-pos (nth 3 form)
                              'help-echo (concat "Move to line "
                                                 line)))
          (goto-char pos)
          (while (re-search-forward regexp nil t)
            (add-text-properties
             (match-beginning 0) (match-end 0)
             (list 'face 'match 'help-echo
                   (format "Move to match %d"
                           (setq match-count (1+ match-count))))))))
      (kill-buffer vlf-occur-data-buffer)
      (goto-char (point-min))
      (insert (propertize
               (format "%d matches from %d lines for \"%s\" in file: %s"
                       match-count all-lines regexp vlf-file)
               'face 'underline)))
    (set-buffer-modified-p nil)
    (vlf-occur-mode)
    (setq vlf-occur-vlf-file vlf-file
          vlf-occur-regexp regexp
          vlf-occur-hexl (nth 2 header)
          vlf-occur-lines all-lines)))

(provide 'vlf-occur)

;;; vlf-occur.el ends here