From: Andreas Gerler Date: Sun, 26 Apr 2026 16:34:01 +0000 (+0200) Subject: update annotate X-Git-Url: http://git.bundesbrandschatzamt.de/?a=commitdiff_plain;h=c883750174d8976d47445ce330b8c1399b5fd36d;p=emacsconfig.git update annotate --- diff --git a/elpa/annotate-20250515.1428/annotate-autoloads.el b/elpa/annotate-20250515.1428/annotate-autoloads.el deleted file mode 100644 index 95e4a982..00000000 --- a/elpa/annotate-20250515.1428/annotate-autoloads.el +++ /dev/null @@ -1,49 +0,0 @@ -;;; annotate-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- -;; Generated by the `loaddefs-generate' function. - -;; This file is part of GNU Emacs. - -;;; Code: - -(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) - - - -;;; Generated autoloads from annotate.el - -(let ((loads (get 'annotate 'custom-loads))) (if (member '"annotate" loads) nil (put 'annotate 'custom-loads (cons '"annotate" loads)) (put 'text 'custom-loads (cons 'annotate (get 'text 'custom-loads))))) -(autoload 'annotate-mode "annotate" "\ -Toggle Annotate mode. - -See https://github.com/bastibe/annotate.el/ for documentation. - -This is a minor mode. If called interactively, toggle the `Annotate -mode' mode. If the prefix argument is positive, enable the mode, and if -it is zero or negative, disable the mode. - -If called from Lisp, toggle the mode if ARG is `toggle'. Enable the -mode if ARG is nil, omitted, or is a positive number. Disable the mode -if ARG is a negative number. - -To check whether the minor mode is enabled in the current buffer, -evaluate the variable `annotate-mode'. - -The mode's hook is called both when the mode is enabled and when it is -disabled. - -(fn &optional ARG)" t) -(register-definition-prefixes "annotate" '("annotat" "on-window-size-change")) - -;;; End of scraped data - -(provide 'annotate-autoloads) - -;; Local Variables: -;; version-control: never -;; no-byte-compile: t -;; no-update-autoloads: t -;; no-native-compile: t -;; coding: utf-8-emacs-unix -;; End: - -;;; annotate-autoloads.el ends here diff --git a/elpa/annotate-20250515.1428/annotate-pkg.el b/elpa/annotate-20250515.1428/annotate-pkg.el deleted file mode 100644 index 3aa255ac..00000000 --- a/elpa/annotate-20250515.1428/annotate-pkg.el +++ /dev/null @@ -1,9 +0,0 @@ -;; -*- no-byte-compile: t; lexical-binding: nil -*- -(define-package "annotate" "20250515.1428" - "Annotate files without changing them." - '((emacs "27.1")) - :url "https://github.com/bastibe/annotate.el" - :commit "dc6e884265c9de5b0e486b9f6bd9509a14b85c94" - :revdesc "dc6e884265c9" - :maintainers '(("Bastian Bechtold" . "bastibe.dev@mailbox.org") - ("cage" . "cage-dev@twistfold.it"))) diff --git a/elpa/annotate-20250515.1428/annotate.el b/elpa/annotate-20250515.1428/annotate.el deleted file mode 100644 index 090a9072..00000000 --- a/elpa/annotate-20250515.1428/annotate.el +++ /dev/null @@ -1,3789 +0,0 @@ -;;; annotate.el --- annotate files without changing them -*- lexical-binding: t; -*- -;; Copyright © 2015 Bastian Bechtold and contributors: -;; Naoya Yamashita (2018) -;; Università degli Studi di Palermo (2019) - -;; Author: Bastian Bechtold -;; Maintainer: Bastian Bechtold , cage -;; URL: https://github.com/bastibe/annotate.el -;; Created: 2015-06-10 -;; Package-Version: 20250515.1428 -;; Package-Revision: dc6e884265c9 -;; Package-Requires: ((emacs "27.1")) - -;; This file is NOT part of GNU Emacs. - -;; Permission is hereby granted, free of charge, to any person -;; obtaining a copy of this software and associated documentation -;; files (the "Software"), to deal in the Software without -;; restriction, including without limitation the rights to use, copy, -;; modify, merge, publish, distribute, sublicense, and/or sell copies -;; of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: - -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. - -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -;;; Commentary: - -;; This package provides the minor mode annotate-mode, which can add -;; annotations to arbitrary files without changing the files -;; themselves. Annotations are saved in the annotate-file -;; (~/.annotations by default). -;; -;; To add annotations to a file, select a region and hit C-c C-a. The -;; region will be underlined, and the annotation will be displayed in -;; the right margin. Annotations are saved whenever the file is saved. -;; -;; Use C-c ] to jump to the next annotation and C-c [ to jump to -;; the previous annotation. Use M-x annotate-export-annotations to -;; save annotations as a no-difference diff file. - -;; Important note for developers: annotation can not overlaps and newline character -;; can not be annotated. - -;;; Code: - -(require 'info) - -(require 'cl-lib) - -;;;###autoload -(defgroup annotate nil - "Annotate files without changing them." - :version "2.4.2" - :group 'text) - -(defvar annotate-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-c C-a") #'annotate-annotate) - (define-key map (kbd "C-c C-d") #'annotate-delete-annotation) - (define-key map (kbd "C-c C-p") #'annotate-change-annotation-text-position) - (define-key map (kbd "C-c C-c") #'annotate-change-annotation-colors) - (define-key map (kbd "C-c C-s") #'annotate-show-annotation-summary) - (define-key map (kbd "C-c ]") #'annotate-goto-next-annotation) - (define-key map (kbd "C-c [") #'annotate-goto-previous-annotation) - map)) - -;;;###autoload -(define-minor-mode annotate-mode - "Toggle Annotate mode. -See https://github.com/bastibe/annotate.el/ for documentation." - :lighter " Ann" - :group 'annotate - (annotate-initialize-maybe)) - -(defcustom annotate-file (locate-user-emacs-file "annotations" ".annotations") - "File where annotations are stored." - :type 'file) - -(defcustom annotate-file-buffer-local nil - "If non nil (default `nil'), for each annotated file \"filename\", a database -\"filename.notes\", containing the annotations, is generated in the -same directory that contains \"filename\"." - :type 'string) - -(defcustom annotate-buffer-local-database-extension "notes" - "The extension appended to the annotated filename to get the -name of the local database annotation" - :type 'string) - -(defcustom annotate-highlight-faces '((:underline "#EEF192") - (:underline "#92EEF1") - (:underline "#F192EE")) - "List of faces for annotated text." - :type '(repeat (plist))) - -(defcustom annotate-annotation-text-faces '((:background "#EEF192" :foreground "black") - (:background "#92EEF1" :foreground "black") - (:background "#F192EE" :foreground "black")) - "List of faces for annotation's text." - :type '(repeat (plist))) - -(defface annotate-prefix - '((t (:inherit default))) - "Face for character used to pad annotation. -This is the fill space between text lines and annotation text.") - -(defcustom annotate-annotation-column 85 - "Where annotations appear." - :type 'number) - -(defcustom annotate-diff-export-options "" - "Options passed to \"diff\" in `annotate-export-annotations'. -This is used when diffing between a buffer with and without -integrated annotations. -Note that there is an implicit \"-u\" at the end of default options -that Emacs passes to the diff program." - :type 'string) - -(defcustom annotate-use-messages t - "Whether status messages may appear in the minibuffer." - :type 'boolean) - -(defcustom annotate-popup-warning-indirect-buffer t - "Whether an information popup message is shown when killing an -annotated indirect buffer." - :type 'boolean) - -(defcustom annotate-integrate-marker " ANNOTATION: " - "Marker that is written before every integrated annotation." - :type 'string) - -(defcustom annotate-integrate-highlight ?~ - "Character used to underline an annotated text." - :type 'character) - -(defcustom annotate-fallback-comment "#" - "When variable `comment-start' is nil use this string instead." - :type 'string) - -(defcustom annotate-blacklist-major-mode '() - "Major modes in which to prevent auto-activation of command `annotate-mode'. -This is consulted when visiting a file. -It can be useful when some mode does not work well with -annotate (like source blocks in `org-mode') as this ensure that it -will be never loaded, see `annotate-initialize-maybe'." - :type '(repeat symbol)) - -(defcustom annotate-summary-ask-query t - "If non nil a prompt asking for a query to filter the database -before showing it in a summary window is used. If nil the -database is not filtered at all." - :type 'boolean) - -(defcustom annotate-database-confirm-deletion t - "If non nil a prompt asking confirmation before deleting a -database file that is going to be empty after saving an annotated -file will be shown." - :type 'boolean) - -(defcustom annotate-annotation-confirm-deletion nil - "If non nil a prompt asking confirmation before deleting an -annotation file will be shown." - :type 'boolean) - -(defcustom annotate-database-confirm-import t - "If non nil a prompt asking confirmation before importing a -database file will be shown." - :type 'boolean) - -(defcustom annotate-annotation-max-size-not-place-new-line 15 - "The maximum \"string-width\" allowed for an annotation to be -placed on the right margin of the window instead of its own line - after the annotated text." - :type 'number) - -(defconst annotate-allowed-positioning-policy - '(:by-length :margin :new-line) - "The allowed values for annotation positioning.") - -(defcustom annotate-annotation-position-policy :by-length - "Policy for annotation's position: -- :new-line - always in a new-line -- :margin - always on right margin -- :by-length - decide by text's length - -if the length is more than the value of -`annotate-annotation-max-size-not-place-new-line' place the -annotation on a new line, place on the right margin -otherwise." - :type 'symbol) - -(defcustom annotate-use-echo-area nil - "Whether annotation text should appear in the echo area only when mouse -id positioned over the annotated text instead of positioning them in -the the buffer (the default)." - :type 'boolean) - -(defcustom annotate-print-annotation-under-cursor nil - "Whether annotation text should appear in the minibuffer when -the cursor is positioned over an annotated text (default: nil). - -Important note: for this changes to take effect also -annotate-use-echo-area must be non nil" - :type 'boolean) - -(defcustom annotate-print-annotation-under-cursor-prefix "ANNOTATION: " - "Prefix that is printed before annotation in the minibuffer when -annotate-print-annotation-under-cursor is non nil" - :type 'string) - -(defcustom annotate-print-annotation-under-cursor-delay 0.5 - "The delay (in seconds) after an annotation id printed in the -minibuffer, when the pursor is placed over an annotated text. - -This variable works only if `annotate-print-annotation-under-cursor' is non nil" - :type 'float) - -(defcustom annotate-warn-if-hash-mismatch t - "Whether a warning message should be printed if a mismatch -occurs, for an annotated file, between the hash stored in the -database annotations and the hash calculated from the actual -file. - -This usually happens if an annotated file (a file with an entry in the -database) is saved with annotated-mode *not* active or the file -has been modified outside Emacs." - :type 'boolean) - -(defcustom annotate-endline-annotate-whole-line t - "Whether trying to annotate the end of line character will -annotate the whole line before (or after if the line is composed -by the newline character only) instead." - :type 'boolean) - -(defcustom annotate-search-region-lines-delta 2 - "When the annotated file is out of sync with its annotation -database the software looks for annotated text in the region with -delta equals to the value of this variable. Units are in number -of lines. The center of the region is the position of the -annotation as defined in the database." - :type 'number) - -(defcustom annotate-autosave t - "Whether annotations should be saved after each user action, -e.g. new annotation created, existing one amended or deleted." - :type 'boolean) - -(defcustom annotate-annotation-expansion-map '() - - "The expansion map for the annotation text. If a substring in the -annotation text matches the string in the first item of each element of -this list, it is expanded with the results of passing the second item — -as a command — to a system shell, if the third item is not null, the -output string of the command's results are trimmed (spaces or some -others non printable characters are removed from both ends, see: -`string-trim'). Example below. - -The expression: - -\(setf annotate-annotation-expansion-map - \\='((\"%d\" \"date +%Y-%m-%d\" t))) - -Will expand any occurrence of \"%d\" in the annotation's text with the -current date (format: \"YYYY-MM-DD\"), moreover the results will be -trimmed" - :type '(repeat (list string string boolean))) - -(defconst annotate-prop-chain-position - 'position) - -(defconst annotate-prop-chain-pos-marker-first - 0) - -(defconst annotate-prop-chain-pos-marker-last - -1) - -(defconst annotate-warn-file-changed-control-string - (concat "The file '%s' has changed on disk " - "from the last time the annotations were saved.\n" - "Chances are that they will not be displayed correctly.") - "The message to warn the user that file has been modified and -annotations positions could be outdated.") - -(defconst annotate-warn-file-searching-annotation-failed-control-string - (concat "The file '%s' has changed on disk " - "from the last time the annotations were saved and " - "Unfortunately was not possible to show annotation %S " - "because i failed looking for test %S.") - "The message to warn the user that file has been modified and -an annotations could not be restored.") - -(defconst annotate-warn-buffer-has-no-valid-file - "Annotations can not be saved: unable to find a file for buffer %S" - "The message to warn the user that a buffer it is not visiting -a valid file to be annotated.") - -(defconst annotate-popup-warn-killing-an-indirect-buffer - (concat "You killed an indirect buffer that contains annotation.\n" - "Annotate mode can not save annotation in an indirect buffer.\n" - "The buffer's content has been saved in a regular buffer " - "(together with its annotations) named:\n\n%S\n\n" - "If you want you can save that buffer in a file and " - "the annotations will be saved as well.") - "The message to warn the user that an annotated indirect buffer -has been killed.") - -(defconst annotate-error-summary-win-filename-invalid - "Error: File not found or in an unsupported format" - "The message to warn the user that file can not be show in -summary window because does not exist or is in an unsupported - format.") - -(defconst annotate-info-valid-file-extensions - '(".info" ".info.gz" ".gz") - "The valid extension for files that contains info document.") - -(defconst annotate-summary-list-prefix " " - "The string used as prefix for each text annotation item in summary window.") - -(defconst annotate-summary-list-prefix-file "* File: " - "The string used as prefix for each annotated file item in summary window.") - -(defconst annotate-summary-list-prefix-snippet "** Annotated text: " - "The string used as prefix for each annotation snippet item in summary window.") - -(defconst annotate-ellipse-text-marker "..." - "The string used when a string is truncated with an ellipse.") - -(defconst annotate-info-root-name "dir" - "The pseudo-filename of info root.") - -(defconst annotate-summary-buffer-name "*annotations*" - "The name of the buffer for summary window.") - -(defconst annotate-dump-from-indirect-bugger-suffix "-was-annotated-indirect-buffer" - "Append this suffix to a buffer generated from an annotated indirect buffer.") - -(defconst annotate-annotation-prompt "Annotation: " - "The prompt when asking user for annotation modification.") - -(defconst annotate-summary-delete-button-label "[delete]" - "The label for the button, in summary window, to delete an annotation.") - -(defconst annotate-summary-replace-button-label "[replace]" - "The label for the button, in summary window, to replace an annotation.") - -(defconst annotate-confirm-deleting-annotation-prompt "Delete this annotation? " - "Prompt to be shown when asking for annotation deletion confirm.") - -(defconst annotate-confirm-appending-newline-prompt "No newline character at the end of the buffer %S, annotation will not be displayed properly: append one? " - "Prompt to be shown when asking for appending a newline at the end of the buffer.") - -(defconst annotate-message-annotation-loaded "Annotations loaded." - "The message shown when annotations has been loaded.") - -(defconst annotate-message-annotations-not-found "No annotations found." - "The message shown when no annotations has been loaded from the database.") - -;;;; buffer locals variables - -(defvar-local annotate-echo-annotation-timer nil - "The buffer local variable bound to a timer that is in charge to print -the annotation under cursor on the echo area.") - -(defvar-local annotate-colors-index-counter 0 - "An always increasing value to address annotation colors -in the customizable colors lists: - -- annotate-highlight-faces -- annotate-annotation-text-faces.") - -;;;; custom errors - -(define-error 'annotate-error "Annotation error") - -(define-error 'annotate-empty-annotation-text-error - "Empty annotation text" - 'annotate-error) - -(define-error 'annotate-no-new-line-at-end-file-error - "No newline found at the end of the buffer" - 'annotate-error) - -(define-error 'annotate-db-file-not-found - "Annotations database file not found" - 'annotate-error) - -(define-error 'annotate-annotate-region-overlaps - "Error: the region overlaps with at least an already existing annotation" - 'annotate-error) - -(define-error 'annotate-query-parsing-error - "Parsing failed:" - 'annotate-error) - -(cl-defmacro annotate-with-disable-read-only (&body body) - "Run BODY with `read-only-mode' temporary disabled." - (let ((read-mode-p (gensym))) - `(let ((,read-mode-p (if buffer-read-only - 1 - -1))) - (when (= ,read-mode-p 1) - (read-only-mode -1)) - ,@body - (when (= ,read-mode-p 1) - (read-only-mode 1))))) - -(defun annotate-annotations-exist-p () - "Does this buffer contains at least one or more annotations?" - (cl-find-if 'annotationp - (overlays-in 0 (buffer-size)))) - -(defun annotate-initialize-maybe () - "Initialize annotate mode only if buffer's major mode is not in the blacklist. -See `annotate-blacklist-major-mode'." - (cl-flet ((shutdown () - (setq annotate-mode t) - (annotate-shutdown) - (setq annotate-mode nil))) - (let ((annotate-allowed-p (with-current-buffer (current-buffer) - (not (apply #'derived-mode-p annotate-blacklist-major-mode))))) - (cond - ((not annotate-allowed-p) - (shutdown)) - (annotate-mode - (when (not (annotate-annotations-exist-p)) - (annotate-initialize))) - (t - (shutdown)))))) - -(cl-defun annotate-buffer-checksum (&optional (object (current-buffer))) - "Calculate an hash for the argument OBJECT." - (secure-hash 'md5 object)) - -(defun annotate-end-of-line-pos () - "Get the position of the end of line and rewind the point's -position (so that it is unchanged after this function is called)." - (line-end-position)) - -(defun annotate-beginning-of-line-pos () - "Get the position of the beginning of line and rewind the point's -position (so that it is unchanged after this function is called)." - (save-excursion - (beginning-of-line) - (point))) - -(defun annotate-annotated-text-empty-p (annotation) - "Does this ANNOTATION contains annotated text?" - (= (overlay-start annotation) - (overlay-end annotation))) - -(defun annotate-annotation-set-face (annotation face) - "Set property face to FACE for ANNOTATION." - (overlay-put annotation 'face face)) - -(defun annotate-annotation-face (annotation) - "Get property face from ANNOTATION." - (overlay-get annotation 'face)) - -(defun annotate-annotation-set-annotation-face (annotation face) - "Set property annotation-face to FACE for ANNOTATION." - (overlay-put annotation 'annotation-face face)) - -(defun annotate-annotation-property-annotation-face (annotation) - "Get property annotation-face from ANNOTATION." - (overlay-get annotation 'annotation-face)) - -(defun annotate-annotation-set-annotation-text (annotation annotation-text) - "Set the annotation's content for ANNOTATION to ANNOTATION-TEXT." - (overlay-put annotation 'annotation annotation-text)) - -(defun annotate-annotation-get-annotation-text (annotation) - "Get the annotation's content for ANNOTATION." - (overlay-get annotation 'annotation)) - -(defun annotate-annotation-set-position (annotation position) - "Set the annotation's position policy for ANNOTATION -to the value bound to POSITION." - (overlay-put annotation 'annotate-position position)) - -(defun annotate-annotation-get-position (annotation) - "Get the annotation's position policy for ANNOTATION." - (overlay-get annotation 'annotate-position)) - -(defun annotate-overlay-maybe-set-position (overlay position) - "Set the annotation's position policy for OVERLAY to the value bound -to POSITION,but only if the value of the property `position' is not null." - (when position - (annotate-annotation-set-position overlay position))) - -(defun annotate-chain-last-ring (chain) - "Get the last ring of CHAIN." - (car (last chain))) - -(defun annotate--remap-chain-pos (annotations) - "Remap ANNOTATIONS as an annotation \"chain\". - -An annotation is a collection of one or more overlays that -contains the property `annotate-prop-chain-position'. - -The value of `annotate-prop-chain-position' in each chain is an -integer starting from: - -`annotate-prop-chain-pos-marker-first' and *always* ending with - -`annotate-prop-chain-pos-marker-last' - -This means that a value of said property for a chain that -contains only an element is equal to -`annotate-prop-chain-pos-marker-last'. - -This function ensure this constrains for the chain ANNOTATION -belong." - (cond - ((< (length annotations) - 1) - annotations) - ((= (length annotations) - 1) - (annotate-annotation-set-chain-last (cl-first annotations))) - (t - (let ((all-but-last (butlast annotations)) - (last-element (car (last annotations)))) - (cl-loop for annotation in all-but-last - for i from annotate-prop-chain-pos-marker-first - do - (annotate-annotation-chain-position annotation i)) - (when last-element - (annotate-annotation-set-chain-last last-element)))))) - -(defun annotate-before-change-fn (a _b) - "This function is added to \"before-change-functions\" hook and -it is called any time the buffer content is changed (so, for -example, text is added or deleted). In particular, it will -rearrange the overlays bounds when an annotated text is -modified (for example a newline is inserted)." - (with-silent-modifications - (save-excursion - (let* ((bol (annotate-beginning-of-line-pos)) - (eol (annotate-end-of-line-pos)) - (ov (cl-remove-if-not #'annotationp - (overlays-in bol eol)))) - (dolist (overlay ov) - (annotate--remove-annotation-property (overlay-start overlay) - (overlay-end overlay)) - ;; check if we are breaking the overlay - (when (<= (overlay-start overlay) - a - (overlay-end overlay)) - (let ((start-overlay (overlay-start overlay))) - ;; delete overlay if there is no more annotated text - (when (<= a start-overlay) - (let ((chain (cl-remove overlay (annotate-find-chain overlay)))) - (delete-overlay overlay) - (annotate--remap-chain-pos chain)))))))))) - -(defun annotate-info-select-fn () - "The function to be called when an info buffer is updated." - (annotate-clear-annotations) - (annotate-load-annotations) - (font-lock-flush)) - -(defun on-window-size-change (_frame) - "The function to call when window-size-change-functions is called, -note that the argument _FRAME is ignored" - (font-lock-flush)) - -(defun annotate--filepath->local-database-name (filepath) - "Generates the file path of the local database form FILEPATH." - (concat (file-name-nondirectory filepath) - "." - annotate-buffer-local-database-extension)) - -(defun annotate--maybe-database-set-buffer-local () - "Sets, if user asked to do so, the annotation database to a -local version (i.e. a different database for each annotated file" - (when annotate-file-buffer-local - (make-local-variable 'annotate-file) - (when-let* ((buffer-file-path (buffer-file-name)) - (parent-directory (file-name-directory buffer-file-path)) - (db-name (annotate--filepath->local-database-name buffer-file-path))) - (setq-local annotate-file db-name)))) - -(defun annotate-timer-print-annotation-function () - "Print annotation under point in the minibuffer. -Used by the timer set in `annotate--maybe-make-timer-print-annotation'. - -See also the customizable variables: `annotate-echo-annotation-timer' and -`annotate-print-annotation-under-cursor'." - (with-current-buffer (current-buffer) - (when annotate-mode - (when-let* ((annotation (annotate-annotation-at (point)))) - (message "%s%s" - annotate-print-annotation-under-cursor-prefix - (annotate-annotation-get-annotation-text annotation)))))) - -(defun annotate-print-annotation-under-cursor-p () - "Non nil if the user configured the package to print -annotation's text in the minibuffer." - (and annotate-use-echo-area - annotate-print-annotation-under-cursor)) - -(defun annotate--maybe-make-timer-print-annotation () - "Set the timer to print the annotation's text in the minibuffer. -Used when the mode is activated." - (when (annotate-print-annotation-under-cursor-p) - (setf annotate-echo-annotation-timer - (run-with-idle-timer annotate-print-annotation-under-cursor-delay - t - #'annotate-timer-print-annotation-function)))) - -(defun annotate--maybe-cancel-timer-print-annotation () - "Cancel the timer to print the annotations text in the minibuffer. -Used when the mode is deactivated." - (when (and (annotate-print-annotation-under-cursor-p) - annotate-echo-annotation-timer - (timerp annotate-echo-annotation-timer)) - (cancel-timer annotate-echo-annotation-timer))) - -(defun annotate-initialize () - "Load annotations and set up save and display hooks." - (annotate--maybe-database-set-buffer-local) - (annotate--maybe-make-timer-print-annotation) - (annotate-load-annotations) - (add-hook 'kill-buffer-hook #'annotate-save-annotations t t) - (add-hook 'kill-emacs-hook #'annotate-save-all-annotated-buffers t nil) - ;; This hook is needed to reorganize the layout of the annotation - ;; text when a window vertically resized - (add-hook 'window-size-change-functions #'on-window-size-change t t) - (add-hook 'before-change-functions #'annotate-before-change-fn t t) - (add-hook 'Info-selection-hook #'annotate-info-select-fn t t) - (if annotate-use-echo-area - (font-lock-add-keywords - nil - '((annotate--font-lock-matcher (2 (annotate--annotation-builder))))) - (font-lock-add-keywords - nil - '((annotate--font-lock-matcher (2 (annotate--annotation-builder)) - (1 (annotate--change-guard))))))) - -(defun annotate-shutdown () - "Clear annotations and remove save and display hooks." - (annotate-clear-annotations) - (annotate--maybe-cancel-timer-print-annotation) - (remove-hook 'kill-buffer-hook #'annotate-save-annotations t) - (remove-hook 'kill-emacs-hook #'annotate-save-all-annotated-buffers nil) - (remove-hook 'window-size-change-functions #'on-window-size-change t) - (remove-hook 'before-change-functions #'annotate-before-change-fn t) - (remove-hook 'Info-selection-hook #'annotate-info-select-fn t) - (if annotate-use-echo-area - (font-lock-remove-keywords - nil - '((annotate--font-lock-matcher (2 (annotate--annotation-builder))))) - (font-lock-remove-keywords - nil - '((annotate--font-lock-matcher (2 (annotate--annotation-builder)) - (1 (annotate--change-guard))))))) - -(defun annotate-overlay-filled-p (overlay) - "Does this OVERLAY contains an `annotation' property?" - (and overlay - (overlayp overlay) - (annotate-annotation-get-annotation-text overlay))) - -(defun annotationp (overlay) - "Is OVERLAY an annotation?" - (annotate-overlay-filled-p overlay)) - -(cl-defmacro annotate-ensure-annotation ((overlay) &body body) - "Runs BODY only if OVERLAY is an annotation (i.e. passes annotationp)." - `(and (annotationp ,overlay) - (progn ,@body))) - -(defun annotate--position-on-annotated-text-p (pos) - "Does POS (as buffer position) corresponds to a character -that belong to some annotated text?" - (let ((annotation (annotate-annotation-at pos))) - (if annotation - t - ;; there is a chance that a point do not belong to the text - ;; rendered as annotated but belong to a chain anyway example: - ;; - ;; legend: - ;; a = annotated text - ;; * = non annotated text - ;; # = annotation - ;; - ;; Create a multiline annotation using region. - ;; - ;; aaaa - ;; aaaa - ;; aaaa - ;; - ;; - ;; aaaa - ;; aaaa - ;; aaaa #### - ;; - ;; place the cursor here: - ;; - ;; aaaa - ;; aaaa - ;; ^ cursor - ;; aaaa #### - ;; - ;; type some text - ;; - ;; aaaa - ;; ***** - ;; aaaa #### - ;; - ;; the text (the asterisks) is not rendered as annotated but as - ;; annotations can not have gaps so we enforce this limitation - ;; and consider it still parts of a chain formed by the - ;; surrounding annotated text. - (let* ((previous-annotation (annotate-previous-annotation-ends pos)) - (next-annotation (annotate-next-annotation-starts pos)) - (previous-chain (annotate-chain-first previous-annotation)) - (next-chain (annotate-chain-first next-annotation))) - (if (and previous-chain - next-chain - (eq previous-chain - next-chain)) - t - nil))))) - -(defun annotate-delete-chains-in-region (from to) - "Deletes all the chains enclosed in the range specified by -positions FROM and TO." - (let* ((enclosed-chains (annotate-annotations-chain-in-range from to))) - (dolist (chain enclosed-chains) - (annotate--delete-annotation-chain (cl-first chain))))) - -(defun annotate-count-newline-in-region (from to) - "Counts the number of newlines character (?\n) in range -specified by FROM and TO." - (cl-count-if (lambda (a) (char-equal a ?\n)) - (buffer-substring-no-properties from to))) - -(defun annotate--expand-annotation-text (annotation-text) - "Expand substrings of ANNOTATION-TEXT, using rules defined in the variable in -`in annotate-annotation-expansion-map'." - (cl-flet ((regex (expansion-item) - (cl-first expansion-item)) - (trimp (expansion-item) - (cl-third expansion-item)) - (command (expansion-item) - (cl-second expansion-item))) - (cl-loop with results = annotation-text - for expansion in annotate-annotation-expansion-map - when (string-match-p (regex expansion) results) - do (let ((expansion-results (shell-command-to-string (command expansion)))) - (when (trimp expansion) - (setf expansion-results (string-trim expansion-results))) - (setf results - (replace-regexp-in-string (regex expansion) - expansion-results - results - t - t))) - finally (return results)))) - -(defun annotate-annotate (&optional color-index) - "Create, modify, or delete annotation. -if COLOR-INDEX is not null must be an index that adresses an element both in -- `annotate-highlight-faces' -and -- `annotate-annotation-text-faces'" - (interactive "P") - (when color-index - (setf color-index (min (max (1- color-index) 0) - (1- (length annotate-highlight-faces))))) - (cl-labels ((create-new-annotation () - ;; create a new annotation in the region returned by `annotate-bound' - (cl-destructuring-bind (start end) - (annotate-bounds) - (let* ((raw-text (read-from-minibuffer annotate-annotation-prompt)) - (annotation-text (annotate--expand-annotation-text raw-text))) - (condition-case nil - (annotate-create-annotation start end annotation-text nil color-index) - (annotate-no-new-line-at-end-file-error - (user-error "Missing newline at the end of the buffer")) - (annotate-empty-annotation-text-error - (user-error "Annotation text is empty")))))) - (cut-right (region-beg region-stop &optional delete-enclosed) - ;; This function will trim on the right one or more - ;; existing chains of overlays that compose an - ;; annotation (i.e. the overlays applied on the - ;; annotated text). After this function is called the - ;; text staring from `region-beg' and ending on - ;; `region-stop' will be cleared of all annotations if - ;; `delete-enclosed' is non null. - (let* ((last-of-chain-to-cut (annotate-chain-last-at region-beg)) - (first-of-chain-to-cut (annotate-chain-first-at region-beg)) - (chain-start (overlay-start first-of-chain-to-cut)) - (chain-end (overlay-end last-of-chain-to-cut)) - (newlines-count (annotate-count-newline-in-region region-beg - chain-end)) - (cut-count (- chain-end - region-beg - newlines-count))) - (cl-loop repeat cut-count do - (when (annotate-annotation-at chain-start) - (annotate--cut-right-annotation first-of-chain-to-cut t))) - (when delete-enclosed - (annotate-delete-chains-in-region chain-end region-stop)))) - (cut-left (region-stop delete-enclosed) - ;; This function will trim on the left one or more - ;; existing chains of overlays that compose an - ;; annotation (i.e. the overlays applied on the - ;; annotated text). After this function is called the - ;; text starting from the last char of the last chain - ;; element of the annotation and ending on - ;; `region-stop' will be cleared of all annotations if - ;; `delete-enclosed' is non null. - (let* ((last-of-chain-to-cut (annotate-chain-last-at region-stop)) - (first-of-chain-to-cut (annotate-chain-first-at region-stop)) - (chain-start (overlay-start first-of-chain-to-cut)) - (chain-end (overlay-end last-of-chain-to-cut)) - (newlines-count (annotate-count-newline-in-region chain-start - region-stop)) - (cut-count (- region-stop - chain-start - newlines-count))) - (cl-loop repeat cut-count do - (when (annotate-annotation-at (1- chain-end)) - (annotate--cut-left-annotation last-of-chain-to-cut))) - (when delete-enclosed - (annotate-delete-chains-in-region chain-end region-stop)))) - (annotate-overwrite-range (start end) - ;; annotate text starting from `start' and ending on - ;; `end', overwriting any other annotation existing in - ;; that range - (goto-char end) - (push-mark (point) t t) - (goto-char start) - (annotate-annotate)) - (annotate-line (eol) - ;; annotate a line that terminate at `eol' - ;; - ;; if the line contains no text before the newline - ;; annotate the next line with text, if any. - ;; - ;; if the line contains a single annotation that spans - ;; the whole line update the existing annotation - ;; - ;; if the line contains no annotation, or more than - ;; one annotation, annotate the whole line that - ;; terminate at `eol' - (let* ((bol (annotate-beginning-of-line-pos)) - (annotations-on-the-line (annotate-annotations-overlay-in-range bol - eol))) - (if (= (length annotations-on-the-line) - 1) - (let* ((annotation (cl-first annotations-on-the-line)) - (start-overlay (overlay-start annotation)) - (end-overlay (overlay-end annotation)) - (annotation-spans-whole-line-p (and (= start-overlay bol) - (= end-overlay eol)))) - (if annotation-spans-whole-line-p - (progn - (goto-char end-overlay) - (push-mark start-overlay t t) - (annotate-change-annotation (overlay-start annotation)) - (pop-mark)) - (annotate-overwrite-range bol eol))) - (annotate-overwrite-range bol eol))))) - (let ((annotation (annotate-annotation-at (point)))) - (cond - ((use-region-p) - (let* ((region-beg (region-beginning)) - (region-stop (region-end)) - (enclosed-chains (annotate-annotations-chain-in-range region-beg region-stop))) - (cond - ((and (annotate--position-on-annotated-text-p region-beg) - (annotate--position-on-annotated-text-p region-stop)) - ;; aaaaaaaaaaaaaaaaaa - ;; ^-----------^ - (let ((starting-chain-at-start (annotate-chain-first-at region-beg)) - (starting-chain-at-end (annotate-chain-first-at region-stop))) - (if (eq starting-chain-at-start - starting-chain-at-end) - (signal 'annotate-annotate-region-overlaps nil) - (cut-left region-stop nil) - (cut-right region-beg region-stop t) - (create-new-annotation)))) - ((annotate--position-on-annotated-text-p region-beg) - ;; aaaabbcc********** - ;; ^------------^ - (cut-right region-beg region-stop t) - (create-new-annotation)) - ((annotate--position-on-annotated-text-p region-stop) - ;; **********cccaaaa - ;; ^------------^ - (cut-left region-stop t) - (create-new-annotation)) - (enclosed-chains - ;; ****aaaaaaaaaaaaaaa**** - ;; ^------------------^ - (annotate-delete-chains-in-region region-beg region-stop) - (create-new-annotation)) - (t - (create-new-annotation))))) - (annotation - (annotate-change-annotation (point)) - (font-lock-flush)) - (t - (if (annotate--position-on-annotated-text-p (point)) - (signal 'annotate-annotate-region-overlaps nil) - (let ((char-maybe-newline (char-after))) - (when char-maybe-newline - (cond - ((not (char-equal char-maybe-newline ?\n)) - (create-new-annotation)) - ((null annotate-endline-annotate-whole-line) - (user-error "The end of line can not be annotated")) - (t ;; annotate the whole line before or after - (save-excursion - (let* ((bol (annotate-beginning-of-line-pos)) - (eol (point))) - (if (/= eol bol) ; text before the newline, annotate it - (annotate-line eol) - (progn ; no text before the new - ; line, annotate next line - ; with proper text - (forward-line 1) - (goto-char (annotate-end-of-line-pos)) - (annotate-annotate)))))))))))) - (when annotate-autosave - (annotate-save-annotations))))) - -(defun annotate-toggle-annotation-text () - "Hide annotation's text at current cursor's point, if such annotation exists." - (interactive) - (when-let* ((chain (annotate-chain-at (point))) - (last-ring (annotate-chain-last-ring chain))) - (if (annotate-tail-overlay-hide-text-p last-ring) - (annotate-chain-show-text chain) - (annotate-chain-hide-text chain)) - (font-lock-flush))) - -(defun annotate-toggle-all-annotations-text () - "Hide annotation's text in the whole buffer." - (interactive) - (let ((chains (annotate-annotations-chain-in-range 0 (buffer-size)))) - (dolist (chain chains) - (if (annotate-tail-overlay-hide-text-p (annotate-chain-last-ring chain)) - (annotate-chain-show-text chain) - (annotate-chain-hide-text chain)))) - (font-lock-flush)) - -(cl-defun annotate-goto-next-annotation (&key (startingp t)) - "Move point to the next annotation." - (interactive) - (let ((annotation (annotate-annotation-at (point)))) - (if startingp - (if annotation - (let* ((chain-last (annotate-chain-last annotation)) - (annotation-last-end (overlay-end chain-last)) - (look-ahead (annotate-next-annotation-starts annotation-last-end))) - (if look-ahead - (progn - (goto-char annotation-last-end) - (annotate-goto-next-annotation :startingp nil)) - (when annotate-use-messages - (message "This is the last annotation.")))) - (let ((next-annotation (annotate-next-annotation-starts (point)))) - (when next-annotation - (goto-char (overlay-start next-annotation))))) - (if annotation - (let ((chain-first (annotate-chain-first annotation))) - (goto-char (overlay-start chain-first))) - (annotate-goto-next-annotation :startingp t))))) - -(cl-defun annotate-goto-previous-annotation (&key (startingp t)) - "Move point to the previous annotation." - (interactive) - (let ((annotation (annotate-annotation-at (point)))) - (if startingp - (if annotation - (let* ((chain-first (annotate-chain-first annotation)) - (annotation-first-start (overlay-start chain-first)) - (look-behind (annotate-previous-annotation-ends annotation-first-start))) - (if look-behind - (progn - (goto-char (1- annotation-first-start)) - (annotate-goto-previous-annotation :startingp nil)) - (when annotate-use-messages - (message "This is the first annotation.")))) - (let ((previous-annotation (annotate-previous-annotation-ends (point)))) - (when previous-annotation - (goto-char (1- (overlay-end previous-annotation)))))) - (if annotation - (let ((chain-last (annotate-chain-last annotation))) - (goto-char (overlay-end chain-last))) - (annotate-goto-previous-annotation :startingp t))))) - -(defun annotate-change-annotation-text-position () - "Change the policy positioning for the annotation under point." - (interactive) - (when-let* ((annotation (annotate-annotation-at (point)))) - (let ((current-position (annotate-annotation-get-position annotation))) - (if (null current-position) - (annotate-annotation-set-position annotation - (cl-first annotate-allowed-positioning-policy)) - (when-let* ((current-position-index (cl-position current-position - annotate-allowed-positioning-policy)) - (next-position-index (mod (1+ current-position-index) - (length annotate-allowed-positioning-policy)))) - (annotate-annotation-set-position annotation - (elt annotate-allowed-positioning-policy - next-position-index))))) - (message "New position policy for this annotation is %s" - (annotate-annotation-get-position annotation)) - (font-lock-flush))) - -(defun annotate-change-annotation-colors () - "Change the colors for the annotation under point." - (interactive) - (cl-flet ((new-color-index (annotation) - (let ((current-annotation-face (annotate-annotation-property-annotation-face annotation))) - (if current-annotation-face - (let* ((current-color-index (cl-position-if (lambda (a) - (cl-equalp current-annotation-face - a)) - annotate-annotation-text-faces)) - (new-color-index (mod (1+ current-color-index) - (length annotate-annotation-text-faces)))) - new-color-index) - 0)))) - (when-let* ((annotation (annotate-annotation-at (point)))) - (let ((new-color-index (new-color-index annotation))) - (annotate-annotation-set-annotation-face annotation - (elt annotate-annotation-text-faces - new-color-index)) - (annotate-annotation-set-face annotation - (elt annotate-highlight-faces - new-color-index)) - (font-lock-flush))))) - -(defun annotate-actual-comment-start () - "String for comment start related to current buffer's major -mode." - (or comment-start - annotate-fallback-comment)) - -(defun annotate-actual-comment-end () - "String for comment ends, if any, related to current buffer's -major mode." - (or comment-end - "")) - -(defun annotate-comments-length () - "Total length of the comment markers (start and end) strings." - (+ (string-width (annotate-actual-comment-start)) - (string-width (annotate-actual-comment-end)))) - -(defun annotate-wrap-in-comment (&rest strings) - "Put comment markers at the start and (if it makes sense) -end of a string. See: annotate-actual-comment-start and -annotate-actual-comment-end." - (apply #'concat (append (list (annotate-actual-comment-start)) - strings - (list (annotate-actual-comment-end))))) - -(cl-defstruct annotate-overlay-lines - overlay - line - relative-start - relative-end) - -(cl-defun annotate--integrate-annotations (&key (use-annotation-marker t) - (as-new-buffer t) - (switch-to-new-buffer t)) - "Export all annotations, This function is not part of the public API." - (cl-labels ((build-input-text-line () - (save-excursion - (annotate--split-lines (buffer-substring-no-properties (point-min) - (point-max)))))) - - (let* ((filename (annotate-actual-file-name)) - (export-buffer (generate-new-buffer (concat filename ".annotated.diff"))) - (annotations-overlays (sort (annotate-all-annotations) - (lambda (a b) - (< (overlay-start a) - (overlay-start b))))) - (lines-count (count-lines (point-min) (point-max))) - (buffer-lines (build-input-text-line)) - (ov-line-pos (mapcar (lambda (ov) - (line-number-at-pos (overlay-start ov))) - annotations-overlays)) - (ov-start-pos-in-line (mapcar (lambda (ov) - (save-excursion - (goto-char (overlay-start ov)) - (let ((bol (annotate-beginning-of-line-pos))) - (- (overlay-start ov) bol)))) - annotations-overlays)) - (ov-end-pos-in-line (mapcar (lambda (ov) - (save-excursion - (goto-char (overlay-start ov)) - (let ((bol (annotate-beginning-of-line-pos))) - (- (overlay-end ov) bol)))) - annotations-overlays)) - (overlay-relative-pos (cl-mapcar (lambda (ov line start end) - (make-annotate-overlay-lines :overlay ov - :line line - :relative-start start - :relative-end end)) - annotations-overlays - ov-line-pos - ov-start-pos-in-line - ov-end-pos-in-line)) - (parent-buffer-mode major-mode) - (output-buffer (if as-new-buffer - export-buffer - (current-buffer)))) - (with-current-buffer output-buffer - (erase-buffer) - (when as-new-buffer - (funcall parent-buffer-mode)) - (cl-loop - for buffer-line in buffer-lines - for line-number from 1 do - (let ((overlays-in-line (cl-remove-if-not (lambda (a) - (= (annotate-overlay-lines-line a) - line-number)) - overlay-relative-pos))) - (when (or (/= (1- line-number) - lines-count) - (not (annotate-string-empty-p buffer-line))) - (insert buffer-line "\n") - (cl-loop for ov-line-pos in overlays-in-line do - (let* ((overlay (annotate-overlay-lines-overlay ov-line-pos)) - (relative-start (annotate-overlay-lines-relative-start ov-line-pos)) - (relative-end (annotate-overlay-lines-relative-end ov-line-pos)) - (padding (if (<= (1- relative-start) 0) - "" - (make-string (1- relative-start) ? ))) - (annotated-lines (annotate--split-lines - (annotate-annotation-get-annotation-text overlay))) - (ov-length (- relative-end relative-start)) - (underline (make-string ov-length - annotate-integrate-highlight))) - (insert (annotate-wrap-in-comment padding underline) "\n") - (when (annotate-chain-last-p overlay) - (when use-annotation-marker - (insert (annotate-wrap-in-comment annotate-integrate-marker) "\n")) - (cl-loop for line in annotated-lines do - (insert (annotate-wrap-in-comment line) "\n"))))))))) - (when (and as-new-buffer - switch-to-new-buffer) - (switch-to-buffer output-buffer)) - (when (not as-new-buffer) - (delete-region (point) (point-max))) - output-buffer))) - -(defun annotate-integrate-annotations () - "Write all annotations into the file as comments below the annotated line. -An example might look like this:" - (interactive) - (annotate--integrate-annotations :use-annotation-marker t - :as-new-buffer nil - :switch-to-new-buffer nil) - (annotate-clear-annotations)) - -(defun annotate-export-annotations () - "Export all annotations as a unified diff file. -An example might look like this: - ---- .../annotate.el/annotate.el 2015-06-19 15:13:36.718796738 +0200 -+++ .../annotate.el/annotate.el 2015-06-19 15:13:36.718796738 +0200 -@@ -73,5 +73,5 @@ - ;;;###autoload - (defface annotate-highlight -- \\='((t (:underline \"coral\")))) -+ \\='((t (:underline \"coral\")))) -# ~~~~~~~~~~~~~~~~~~ -# this doesn't work in cli - \"Face for annotation highlights.\") - -This diff does not contain any changes, but highlights the -annotation, and can be conveniently viewed in diff-mode." - (interactive) - (let ((buffer (annotate--integrate-annotations :switch-to-new-buffer nil))) - (diff-buffers (current-buffer) buffer annotate-diff-export-options))) - -(defun annotate--font-lock-matcher (limit) - "Finds the next annotation. Matches two areas: -- the area between the overlay and the annotation -- the newline that will display the annotation - -The first match will get `annotate--change-guard' as its -`insert-in-front-hook', to make sure that if a newline is inserted -between the overlay and the annotation, the \"display\" property of -the newline is properly disposed of. - -The second match will get `annotate--annotation-builder' as its -`display' property, which makes the newline look like an -annotation plus the newline." - (goto-char (next-overlay-change (point))) - (if (>= (point) limit) - nil ; no match found before limit - (progn - ;; go to the end of the longest annotation under point - (let ((overlays (sort (cl-remove-if (lambda (a) - (not (and (annotationp a) - (< (overlay-end a) - limit)))) - (overlays-at (point))) - (lambda (x y) - (> (overlay-end x) - (overlay-end y)))))) - (when overlays - (goto-char (overlay-end (car overlays))))) - ;; capture the area from the overlay to EOL (regexp match #1) - ;; for the modification guard and the newline itself (regexp - ;; match #2) for the annotation. - (re-search-forward "\\(.*\\(\n\\)\\)" limit t)))) - -(cl-defstruct annotate-group - words - start-word) - -(defun annotate-group-by-width (text maximum-width) - "Groups TEXT in a list formed by chunks of maximum size equal -to MAXIMUM-WIDTH." - (cl-labels ((next-word (words) - (or (cl-first words) - "")) - (join-until-width (words &optional (word nil)) - (cond - ((null words) - (make-annotate-group :words nil - :start-word word)) - (t - (let* ((next-word (next-word words)) - (new-word (if word - (concat word " " next-word) - next-word))) - (if (<= (string-width new-word) - maximum-width) - (join-until-width (cl-rest words) new-word) - (make-annotate-group :words words - :start-word (or word next-word))))))) - (split-position (text column-max-width) - (let ((character-width (length text)) - (column-width (string-width text))) - (if (= character-width column-width) - column-max-width - (let* ((res 0) - (so-far "")) - (cl-loop for i from 0 below column-max-width - until (>= (string-width so-far) - column-max-width) - do - (setf so-far (concat so-far (string (elt text i)))) - (setf res i)) - res)))) - (%group (words so-far) - (cond - ((null words) - so-far) - ((<= (string-width (cl-first words)) - maximum-width) - (let* ((potential-start (join-until-width words)) - (word (annotate-group-start-word potential-start)) - (nonjoined-words (annotate-group-words potential-start)) - (rest-words nonjoined-words) - (potential-start word)) - (%group rest-words - (append (list potential-start) - so-far)))) - (t - (let* ((word (cl-first words)) - (rest-words (cl-rest words)) - (split-position (split-position word maximum-width)) - (prefix (cl-subseq word 0 split-position)) - (next-word (if rest-words - (cl-first rest-words) - "")) - (raw-suffix (cl-subseq word split-position)) - (suffix (if rest-words - (concat raw-suffix " " next-word) - raw-suffix))) - (%group (append (list suffix) - (cl-rest rest-words)) - (append (list prefix) - so-far)))))) - (%split-words (text) - (save-match-data (split-string text "[[:space:]]" t)))) - (if (< maximum-width 1) - nil - (let* ((words (%split-words text)) - (grouped (reverse (%group words '())))) - grouped)))) - -(cl-defun annotate-safe-subseq (seq from to &optional (value-if-limits-invalid seq)) - "Return a substring of SEQ or VALUE-IF-LIMITS-INVALID -sequence if FROM or TO are invalids." - (cond - ((< to from) - value-if-limits-invalid) - ((or (< from 0) - (> from (length seq)) - (> to (length seq))) - value-if-limits-invalid) - (t - (cl-subseq seq from to)))) - -(defun annotate-lineate (text line-width) - "Breaks TEXT into lines to fit in the annotation space with width LINE-WIDTH." - (cl-labels ((pad (string max-width add-newline-p) - (if (null string) - "" - (let* ((size (string-width string)) - (rest-width (max (- max-width - size) - 0)) - (padding (make-string rest-width - ? ))) - (if add-newline-p - (concat string padding "\n") - (concat string padding))))) - (%subseq (seq from to) - (if (= (length seq) 1) - nil - (annotate-safe-subseq seq from to nil)))) - (let* ((current-window (get-buffer-window (current-buffer))) - (theoretical-line-width (- (window-body-width current-window) - annotate-annotation-column)) - (available-width (if (> theoretical-line-width 0) - theoretical-line-width - line-width)) - (lineated-list (annotate-group-by-width text available-width)) - (max-width (apply #'max - (mapcar #'string-width lineated-list))) - (all-but-last-lineated-list (%subseq lineated-list 0 (1- (length lineated-list)))) - (last-line (if all-but-last-lineated-list - (car (last lineated-list)) - (cl-first lineated-list))) - (lineated (cl-mapcar (lambda (a) - (pad a max-width t)) - all-but-last-lineated-list))) - (apply #'concat - (append lineated - (list (pad last-line max-width nil))))))) - -(cl-defun annotate--split-lines (text &optional (separator "\n")) - "Return TEXT splitted by SEPARATOR (default: \"\n\")." - (save-match-data - (split-string text separator))) - -(defun annotate--join-with-string (strings junction) - "Join list of string in STRINGS using string JUNCTION." - (cl-reduce (lambda (a b) (concat a junction b)) - strings)) - -(defun annotate-wrap-annotation-in-box (annotation-overlay - begin-of-line - end-of-line - annotation-on-is-own-line-p) - "Pads or breaks annotation text (as property of -ANNOTATION-OVERLAY so that all lines have the same width. - -If annotation is a placed on the margin of a window (that is -ANNOTATION-ON-IS-OWN-LINE-P is -nil) the text is broken (regardless of words) to fit on the side -of the window using BEGIN-OF-LINE END-OF-LINE. - -If annotation is a note that is placed in its own line the text is padded -with spaces so that a \"box\" surround the text without seams, e.g: - -aaa aaa -aa -> aa* -a a**" - (let ((annotation-text (annotate-annotation-get-annotation-text annotation-overlay))) - (cl-labels ((boxify-multiline (raw-annotation-text &optional add-space-at-end) - (let* ((lines (annotate--split-lines raw-annotation-text)) - (lines-widths (mapcar #'string-width lines)) - (max-width (cl-reduce (lambda (a b) (if (> a b) - a - b)) - lines-widths - :initial-value -1)) - (padding-sizes (mapcar (lambda (a) (- max-width - (string-width a))) - lines)) - (paddings (mapcar (lambda (a) (make-string a ? )) - padding-sizes)) - (box-lines (cl-mapcar (lambda (a b) (concat a b)) - lines paddings)) - (almost-boxed (annotate--join-with-string box-lines "\n"))) - (if add-space-at-end - (concat almost-boxed " ") - almost-boxed)))) - (if annotation-on-is-own-line-p - (list (boxify-multiline annotation-text t)) - (let* ((lineated (annotate-lineate annotation-text - (- end-of-line begin-of-line))) - (boxed (boxify-multiline lineated nil))) - (annotate--split-lines boxed)))))) - -(defun annotate--current-highlight-face () - "Reurns the current annotation color theme." - (elt annotate-highlight-faces - (mod annotate-colors-index-counter - (length annotate-highlight-faces)))) - -(defun annotate--current-annotation-text-face () - "Reurns the current annotation's text color theme." - (elt annotate-annotation-text-faces - (mod annotate-colors-index-counter - (length annotate-annotation-text-faces)))) - -(defun annotate--annotation-builder () - "Searches the line before point for annotations, and returns a -\"facespec\" with the annotation in its \"display\" property." - (save-excursion - ;; (let ((newline-position (point))) - (goto-char (1- (point))) ; we start at the start of the previous line - ;; find overlays in the preceding line - (let ((prefix-first (annotate-make-prefix)) ; white spaces - ; before first - ; line of - ; annotation - (prefix-rest (make-string annotate-annotation-column ? )) - (bol (progn (beginning-of-line) (point))) - (eol (progn (end-of-line) (point))) - (annotation-text "") - (overlays nil) - (overlays-counter 1) - (hidden-text nil)) - ;; include previous line if point is at bol: - (when (null (overlays-in bol eol)) - (setq bol (1- bol))) - (setq overlays - (sort (cl-remove-if-not #'annotationp - (overlays-in bol eol)) - (lambda (x y) - (< (overlay-end x) (overlay-end y))))) - ;; configure each annotation's properties and place it on the - ;; the window. The default position of the annotation (newline - ;; or right margin) is indicated by the value of the - ;; variable: `annotate-annotation-position-policy'. - (dolist (ov overlays) - (let* ((last-ring-p (annotate-chain-last-p ov)) - (annotation-face (annotate-annotation-face ov)) ; added by annotate-create-annotation - (annotation-text-face (annotate-annotation-property-annotation-face ov)) ; added by annotate-create-annotation - (position (annotate-annotation-get-position ov)) - (annotation-long-p (> (string-width (annotate-annotation-get-annotation-text ov)) - annotate-annotation-max-size-not-place-new-line)) - (new-position-policy position)) - (if (null position) - (setf new-position-policy - (if (eq annotate-annotation-position-policy - :by-length) - (if annotation-long-p - :new-line - :margin) - annotate-annotation-position-policy)) - (setf new-position-policy - (if (eq position - :by-length) - (if annotation-long-p - :new-line - :margin) - position))) - (let* ((wrap-in-a-new-line (eq new-position-policy :new-line)) - (multiline-annotation (annotate-wrap-annotation-in-box ov - bol - eol - wrap-in-a-new-line)) - (annotation-stopper (if (not (eq new-position-policy - :margin)) - (if (= overlays-counter - (length overlays)) - "\n" - "") - "\n")) - (tail-hidden-text-p (and last-ring-p - (annotate-tail-overlay-hide-text-p ov)))) - (setf hidden-text tail-hidden-text-p) - (cl-incf overlays-counter) - (annotate-annotation-set-face ov annotation-face) - (annotate-annotation-set-annotation-face ov annotation-text-face) - (when (and (not annotate-use-echo-area) - (not hidden-text) - (annotate-chain-last-p ov)) - (when (and new-position-policy - (not (eq new-position-policy :margin))) - (setf prefix-first " \n")) - (dolist (l multiline-annotation) - (setq annotation-text - (concat annotation-text - prefix-first - (propertize l 'face annotation-text-face) - annotation-stopper)) - ;; white space before for all but the first annotation line - (if (eq new-position-policy - :new-line) - (setq prefix-first (concat prefix-first prefix-rest)) - (setq prefix-first prefix-rest))))))) - (when (not annotate-use-echo-area) - ;; build facespec with the annotation text as display property - (if (string= annotation-text "") - ;; annotation has been removed: remove display prop - (list 'face 'default 'display nil) - ;; annotation has been changed/added: change/add display prop - (list 'face 'default 'display annotation-text)))))) - -(defun annotate--remove-annotation-property (_begin end) - "Cleans up annotation properties associated within a region -surrounded by _BEGIN and END." - (when (and annotate-mode - (> (buffer-size) 0)) - (with-silent-modifications - (annotate-with-disable-read-only - ;; copy undo list - (let ((saved-undo-list (copy-tree buffer-undo-list t))) - ;; inhibit property removal to the undo list (and empty it too) - (buffer-disable-undo) - (save-excursion - (goto-char end) - ;; go to the EOL where the - ;; annotated newline used to be - (end-of-line) - ;; strip dangling display property - (when (< (point) - (point-max)) - (remove-text-properties (point) (1+ (point)) '(display nil)))) - ;; restore undo list - (setf buffer-undo-list saved-undo-list) - (buffer-enable-undo)))))) - -(defun annotate-annotations-overlay-in-range (from-position to-position) - "Return the annotations overlays that are enclosed in the range -defined by FROM-POSITION and TO-POSITION." - (let ((annotations ()) - (counter (max 0 (1- from-position)))) - (catch 'scan-loop - (while (<= counter - to-position) - (cl-incf counter) - (let ((annotation (annotate-next-annotation-starts counter))) - (if (annotationp annotation) - (let ((chain-end (overlay-end (annotate-chain-last annotation))) - (chain-start (overlay-start (annotate-chain-first annotation)))) - (setf counter chain-end) - (when (and (>= chain-start from-position) - (<= chain-end to-position)) - (cl-pushnew annotation annotations))) - (throw 'scan-loop t))))) - (reverse annotations))) - -(defun annotate-annotations-chain-in-range (from-position to-position) - "Return the annotations (chains) that are enclosed in the range -defined by FROM-POSITION and TO-POSITION." - (let ((annotations (annotate-annotations-overlay-in-range from-position to-position)) - (chains ())) - (cl-loop for annotation in annotations do - (let ((chain (annotate-find-chain annotation))) - (cl-pushnew chain chains :test (lambda (a b) (eq (cl-first a) (cl-first b)))))) - (reverse chains))) - -(defun annotate--change-guard () - "Return a `facespec' with an `insert-behind-hooks' property -that strips dangling `display' properties of text insertions if -text is inserted. This cleans up after newline insertions between -an overlay and it's annotation." - (list 'face - nil - 'insert-in-front-hooks - '(annotate--remove-annotation-property))) - -(defun annotate-prefix-lines (prefix text &optional omit-trailing-null) - "Prepend PREFIX to each line in TEXT. -If OMIT-TRAILING-NULL is non null, empty line at the end of -text will be discarded." - (let ((lines (annotate--split-lines text "\n"))) - (when omit-trailing-null - (let ((last-not-empty (cl-position-if-not #'annotate-string-empty-p - lines - :from-end t))) - (setf lines (cl-subseq lines 0 (1+ last-not-empty))))) - (apply #'concat (mapcar (lambda (l) (concat prefix l "\n")) lines)))) - -;;; database related procedures - -(defun annotate-info-actual-filename () - "The info filename that feed this buffer or nil if not this -buffer is not on info-mode" - (annotate-guess-filename-for-dump Info-current-file nil)) - -(cl-defun annotate-indirect-buffer-p (&optional (buffer (current-buffer))) - "Returns non nil if BUFFER (default the current buffer) is an indirect buffer." - (buffer-base-buffer buffer)) - -(defun annotate-indirect-buffer-current-p () - "Returns non nil if the current buffer is an indirect buffer." - (annotate-indirect-buffer-p)) - -(defun annotate-actual-file-name () - "Get the actual file name of the current buffer." - (cond - ((annotate-indirect-buffer-current-p) - nil) - (t - (substring-no-properties (or (annotate-info-actual-filename) - (buffer-file-name) - (buffer-file-name (buffer-base-buffer)) - ""))))) - -(cl-defun annotate-guess-filename-for-dump (filename - &optional (return-filename-if-not-found-p t)) - "Guess an acceptable file name suitable for metadata database from FILENAME." - (cond - ((annotate-string-empty-p filename) - nil) - ((file-exists-p filename) - filename) - (t - (let ((found (if return-filename-if-not-found-p - filename - nil))) - (cl-block surrounding - (dolist (extension annotate-info-valid-file-extensions) - (let ((filename-maybe (concat filename extension))) - (when (file-exists-p filename-maybe) - (setf found filename-maybe) - (cl-return-from surrounding found))))) - found)))) - -(defun annotate-make-annotation-dump-entry (filename file-annotations checksum) - "Make an annotation record: see `annotate-load-annotations'." - (list filename - file-annotations - checksum)) - -(defun annotate-make-record (filename file-annotations checksum) - "Make an annotation record: see `annotate-load-annotations'." - (annotate-make-annotation-dump-entry filename file-annotations checksum)) - -(defun annotate-color-index-from-dump (record) - "Get the checksum field from an annotation list loaded from a -file." - (and (> (length record) 3) - (nth 4 record))) - -(defun annotate-placement-policy-from-dump (record) - "Get the checksum field from an annotation list loaded from a -file." - (and (> (length record) 4) - (nth 5 record))) - -(defun annotate-checksum-from-dump (record) - "Get the checksum field from an annotation list loaded from a -file." - (and (> (length record) 2) - (nth 2 record))) - -(defun annotate-annotations-from-dump (record) - "Get the annotations field from an annotation list loaded from a -file." - (nth 1 record)) - -(defun annotate-filename-from-dump (record) - "Get the filename field from an annotation list loaded from a -file." - (cl-first record)) - -(defun annotate-beginning-of-annotation (annotation) - "Get the starting point of an annotation. The arg ANNOTATION must be a single -annotation field got from a file dump of all annotated buffers, -essentially what you get from: -\(annotate-annotations-from-dump (nth index (annotate-load-annotations))))." - (cl-first annotation)) - -(defun annotate-ending-of-annotation (annotation) - "Get the ending point of an annotation. The arg ANNOTATION must be a single -annotation field got from a file dump of all annotated buffers, -essentially what you get from: -\(annotate-annotations-from-dump (nth index (annotate-load-annotations))))." - (cl-second annotation)) - -(defun annotate--interval-left-limit (a) - "Given an annotation record A returns the left limit of the annotated text." - (cl-first a)) - -(defun annotate--interval-right-limit (a) - "Given an annotation record A returns the right limit of the annotated text." - (cl-second a)) - -(defun annotate--make-interval (left-limit right-limit) - "Make an interval from LEFT-LIMIT and RIGHT-LIMIT." - (list left-limit right-limit)) - -(defun annotate-annotation-interval (annotation) - "Return the limits where ANNOTATION is applied. -The limit is a list of two numbers (LEFT RIGHT) representing of the portion -of the buffer where this annotation is applied. -Note that this function returns the character interval -yyyyyyyy ggg - ^^^^^^^ ← Annotation interval in the database - (extends for one more than the last character) - |----| ← The interval that this function returns. - -In other terms the interval in the database is a closed interval while -the interval that this function return is closed on the left and open on -the right side." - (annotate--make-interval (annotate-beginning-of-annotation annotation) - (1- (annotate-ending-of-annotation annotation)))) - -(defun annotate-annotation-string (annotation) - "Get the text of an annotation. The arg ANNOTATION must be a single -annotation field got from a file dump of all annotated buffers, -essentially what you get from: -\(annotate-annotations-from-dump (nth index (annotate-load-annotations))))." - (nth 2 annotation)) - -(defun annotate-annotated-text (annotation) - "Get the annotated text of an annotation. The arg ANNOTATION must be a single -annotation field got from a file dump of all annotated buffers, -essentially what you get from: -\(annotate-annotations-from-dump (nth index (annotate-load-annotations))))." - (and (> (length annotation) 3) - (nth 3 annotation))) - -(defun annotate-save-all-annotated-buffers () - "Save the annotations for all buffer where `annotate-mode' is active." - (let ((all-annotated-buffers (annotate-buffers-annotate-mode))) - (cl-loop for annotated-buffer in all-annotated-buffers do - (with-current-buffer annotated-buffer - (annotate-save-annotations))))) - -(cl-defun annotate--dump-indirect-buffer (annotations &optional (indirect-buffer (current-buffer))) - "Clone an annotated indirect buffer into a new buffer. -ANNOTATIONS containd the annotations and INDIRECT-BUFFER -\(default the current buffer) is the buffer to be cloned." - (when annotations - (let* ((new-buffer-name (generate-new-buffer-name (concat (buffer-name indirect-buffer) - annotate-dump-from-indirect-bugger-suffix))) - (new-buffer (get-buffer-create new-buffer-name)) - (indirect-content (with-current-buffer (current-buffer) - (buffer-string)))) - (with-current-buffer new-buffer - (annotate-mode -1) - (insert indirect-content) - ;; when launching the command `(annotate-mode 1)' annotate - ;; mode refuses to add the hooks if annotations are already - ;; present in the buffer. - ;; So the right way here is: first activate the mode and then - ;; add the annotations - (annotate-mode 1) - (cl-loop for annotation in annotations do - (let ((annotation-start (annotate-beginning-of-annotation annotation)) - (annotation-end (annotate-ending-of-annotation annotation)) - (annotation-text (annotate-annotation-string annotation))) - (annotate-create-annotation annotation-start - annotation-end - annotation-text - nil))) - (pop-to-buffer new-buffer) - (let* ((info-message (message annotate-popup-warn-killing-an-indirect-buffer - (buffer-name new-buffer))) - (user-choice (when annotate-popup-warning-indirect-buffer - (x-popup-dialog t (list info-message - (cons "OK" :ok) - (cons "Never show again" :bury)))))) - (when (eq user-choice :bury) - (customize-save-variable 'annotate-popup-warning-indirect-buffer nil))))))) - -(defun annotate-save-annotations () - "Save all annotations to disk." - (interactive) - (let ((file-annotations (cl-remove-if (lambda (a) - (= (annotate-beginning-of-annotation a) - (annotate-ending-of-annotation a))) - (annotate-describe-annotations))) - (all-annotations (annotate-load-annotation-data t)) - (filename (annotate-guess-filename-for-dump (annotate-actual-file-name)))) - (cond - (filename - (if (assoc-string filename all-annotations) - (setcdr (assoc-string filename all-annotations) - (list file-annotations - (annotate-buffer-checksum))) - (setq all-annotations - (push (annotate-make-annotation-dump-entry filename - file-annotations - (annotate-buffer-checksum)) - all-annotations))) - ;; remove duplicate entries (a user reported seeing them) - (dolist (entry all-annotations) - (delete-dups entry)) - ;; skip files with no annotations - (annotate-dump-annotation-data (cl-remove-if (lambda (entry) - (null (annotate-annotations-from-dump entry))) - all-annotations)) - (when annotate-use-messages - (message "Annotations saved."))) - ((annotate-indirect-buffer-current-p) - (annotate--dump-indirect-buffer file-annotations)) - (file-annotations - (lwarn '(annotate-mode) - :warning - annotate-warn-buffer-has-no-valid-file - (current-buffer)))))) - -(defun annotate-load-annotation-old-format () - "Load all annotations from disk in old format." - (interactive) - (let ((annotations (cdr (assoc-string (annotate-actual-file-name) - (annotate-load-annotation-data t))))) - ;; remove empty annotations created by earlier bug: - (setq annotations (cl-remove-if (lambda (ann) (null (nth 2 ann))) - annotations)) - (when (and (null annotations) - annotate-use-messages) - (message annotate-message-annotations-not-found)) - (when (not (null annotations)) - (save-excursion - (dolist (annotation annotations) - (let ((start (annotate-beginning-of-annotation annotation)) - (end (annotate-ending-of-annotation annotation)) - (annotation-string (annotate-annotation-string annotation))) - (annotate-create-annotation start end annotation-string nil))))) - (font-lock-flush) - (when annotate-use-messages - (message annotate-message-annotation-loaded)))) - -(defun annotate-load-annotations () - "Load all annotations from disk and redraw the buffer to render the annotations. - -The format of the database is: - -\(RECORD-1 RECORD-2 ... RECORD-N) - -Each record is: - -\(FILENAME ANNOTATIONS CHECKSUM) - -where: - -FILENAME: a string identifying a file on the file-system, or the -string \"dir\" for top-level info file. - -CHECKSUM: a string used to fingerprint the annotate file above, -used to check if a file has been modified. - -annotations: - -\(ANNOTATION-1 ANNOTATION-2 ... ANNOTATION-N) or nil - -finally annotation is: - -\(START END ANNOTATION-STRING ANNOTATED-TEXT COLOR-INDEX) - -START: the buffer position where annotated text start -END: the buffer position where annotated text ends -ANNOTATION-STRING: the text of annotation -ANNOTATED-TEXT: the substring of buffer from START to END (as above) -COLOR-INDEX: the index position in `annotate-annotation-text-faces' and - `annotate-highlight-faces' to chode the annotation's visual -POSITIONING-POLICY: a keyword representing the stategy for the annotation's - text position; the allowed values are specified in: - `annotate-allowed-positioning-policy' - -example: - -\\='(\"/foo/bar\" ((0 9 \"note\" \"annotated\" 0 :margin)) hash-as-hex-string)." - (interactive) - (cl-labels ((old-format-p (annotation) - (not (stringp (cl-first (last annotation)))))) - (let* ((filename (annotate-actual-file-name)) - (all-annotations-data (annotate-load-annotation-data t)) - (annotation-dump (assoc-string filename all-annotations-data)) - (annotations (annotate-annotations-from-dump annotation-dump)) - (old-checksum (annotate-checksum-from-dump annotation-dump)) - (new-checksum (annotate-buffer-checksum))) - (if (old-format-p annotation-dump) - (annotate-load-annotation-old-format) - (when (and annotate-warn-if-hash-mismatch - (not (old-format-p annotation-dump)) - old-checksum - new-checksum - (not (string= old-checksum new-checksum))) - (lwarn '(annotate-mode) - :warning - annotate-warn-file-changed-control-string - filename)) - (cond - ((and (null annotations) - annotate-use-messages) - (message annotate-message-annotations-not-found)) - (annotations - (save-excursion - (dolist (annotation annotations) - (let* ((start (annotate-beginning-of-annotation annotation)) - (end (annotate-ending-of-annotation annotation)) - (annotation-string (annotate-annotation-string annotation)) - (annotated-text (annotate-annotated-text annotation)) - (dump-color-index (annotate-color-index-from-dump annotation)) - (color-index (if (and dump-color-index - (< dump-color-index - (length annotate-highlight-faces))) - dump-color-index - nil)) - (position (annotate-placement-policy-from-dump annotation))) - (annotate-create-annotation start - end - annotation-string - annotated-text - color-index - position)))))) - (font-lock-flush) - (when annotate-use-messages - (message annotate-message-annotation-loaded)))))) - -(defun annotate-db-clean-records (records-db) - "Remove records from arg RECORDS-DB that have empty annotation, example: - -\\='((\"/foo/bar.dat\" nil \"abababababababababababababab\") - (\"/foo/baz.dat\" ((0 9 \"note\" \"annotated\")) \"abababababababababababababab\")) - -will become: - -\\='((\"/foo/baz.dat\" ((0 9 \"note\" \"annotated\")) \"abababababababababababababab\")) - -i.e. the first record is removed." - (cl-remove-if (lambda (a) (null (annotate-annotations-from-dump a))) - records-db)) - -(defun annotate-db-purge () - "Update database *on disk* removing all the records with empty -annotation." - (interactive) - (let ((db (annotate-db-clean-records (annotate-load-annotation-data t)))) - (annotate-dump-annotation-data db))) - -(defun annotate--expand-record-path (record) - "Expand file component of RECORD." - (let* ((short-filename (annotate-filename-from-dump record)) - (annotations (annotate-annotations-from-dump record)) - (file-checksum (annotate-checksum-from-dump record)) - (expandp (not (or (file-remote-p short-filename) - (annotate-info-root-dir-p short-filename)))) - (actual-filename (if expandp - (expand-file-name short-filename) - short-filename))) - (annotate-make-record actual-filename - annotations - file-checksum))) - -(defun annotate--deserialize-database-file (file) - "Return a sexp from the annotation database contained in FILE." - (with-temp-buffer - (let* ((annotations-file file) - (attributes (file-attributes annotations-file))) - (cond - ((not (file-exists-p annotations-file)) - (signal 'annotate-db-file-not-found (list annotations-file))) - ((= (file-attribute-size attributes) - 0) - nil) - (t - (insert-file-contents annotations-file) - (mapcar #'annotate--expand-record-path (read (current-buffer)))))))) - -(defun annotate-load-annotation-data (&optional ignore-errors) - "Read and returns saved annotations." - (if ignore-errors - (ignore-errors (annotate--deserialize-database-file annotate-file)) - (annotate--deserialize-database-file annotate-file))) - -(defun annotate-dump-annotation-data (data &optional save-empty-db) - "Save DATA into annotation file." - (cond - ((or save-empty-db - data) - (with-temp-file annotate-file - (let* ((print-length nil) - (%abbreviate-filename (lambda (record) - (let ((full-filename (annotate-filename-from-dump record)) - (annotations (annotate-annotations-from-dump record)) - (file-checksum (annotate-checksum-from-dump record))) - (annotate-make-record (abbreviate-file-name full-filename) - annotations - file-checksum)))) - (actual-data (mapcar %abbreviate-filename data))) - (prin1 actual-data (current-buffer))))) - ((file-exists-p annotate-file) - (let* ((confirm-message "Delete annotations database file %S? ") - (delete-confirmed-p (or (not annotate-database-confirm-deletion) - (y-or-n-p (format confirm-message annotate-file))))) - (if delete-confirmed-p - (condition-case err - (delete-file annotate-file t) - (error (message "error removing annotation database: %S" - (error-message-string err)))) - (annotate-dump-annotation-data data t)))))) - -(cl-defmacro with-matching-annotation-fns ((filename - beginning - ending) - &body body) - "Anaphoric macro to build functions to find annotations." - `(let ((filename-match-p (lambda (record) - (string= (annotate-filename-from-dump record) - ,filename))) - (annotation-limits-match-p (lambda (a) - (and (= (annotate-beginning-of-annotation a) - ,beginning) - (= (annotate-ending-of-annotation a) - ,ending))))) - ,@body)) - -(defun annotate-db-remove-annotation (db-records - record-filename - annotation-beginning - annotation-ending) - "Remove from database DB-RECORDS the annotation identified by -the triplets RECORD-FILENAME, ANNOTATION-BEGINNING and - ANNOTATION-ENDING; if such annotation does exists." - (with-matching-annotation-fns - (record-filename - annotation-beginning - annotation-ending) - (let ((file-matched-record (cl-find-if filename-match-p db-records))) - (if file-matched-record - (let* ((rest-of-db (cl-remove-if filename-match-p db-records)) - (new-annotations (cl-remove-if annotation-limits-match-p - (annotate-annotations-from-dump file-matched-record))) - (checksum (annotate-checksum-from-dump file-matched-record)) - (new-record (annotate-make-record record-filename - new-annotations - checksum))) - (push new-record - rest-of-db)) - db-records)))) - -(defun annotate-db-replace-annotation (db-records - record-filename - annotation-beginning - annotation-ending - replacing-text) - "Replace the text of annotation from database DB-RECORDS -identified by the triplets RECORD-FILENAME, - ANNOTATION-BEGINNING and ANNOTATION-ENDING; if such - annotation does exists." - (with-matching-annotation-fns - (record-filename - annotation-beginning - annotation-ending) - (let ((file-matched-record (cl-find-if filename-match-p db-records))) - (if file-matched-record - (let ((old-annotation (cl-find-if annotation-limits-match-p - (annotate-annotations-from-dump file-matched-record)))) - (if old-annotation - (let* ((rest-of-db (cl-remove-if filename-match-p db-records)) - (rest-annotations (cl-remove-if annotation-limits-match-p - (annotate-annotations-from-dump file-matched-record))) - (checksum (annotate-checksum-from-dump file-matched-record)) - (new-annotation (annotate-make-annotation annotation-beginning - annotation-ending - replacing-text - (annotate-annotated-text old-annotation))) - (new-record (annotate-make-record record-filename - (append (list new-annotation) - rest-annotations) - checksum))) - (push new-record - rest-of-db)) - db-records)) - db-records)))) - -(defun annotate-db-annotations-starts-before-p (a b) - "Non nil if annotation A starts before B. - -In this context annotation means annotation loaded from local -database not the annotation shown in the buffer (therefore these -arguments are \"record\" as called in the other database-related -functions)." - (< (annotate-beginning-of-annotation a) - (annotate-beginning-of-annotation b))) - -;;;; database related procedures ends here - -(defun annotate-clear-annotations () - "Clear all current annotations." - (interactive) - (let ((overlays (overlays-in 0 (buffer-size)))) - ;; only remove annotations, not all overlays - (setq overlays (cl-remove-if - (lambda (ov) (not (annotationp ov))) - overlays)) - (dolist (ov overlays) - (annotate--remove-annotation-property (overlay-start ov) - (overlay-end ov)) - (delete-overlay ov)))) - -(defun annotate-string-empty-p (a) - "Is the arg A an empty string or null?" - (or (null a) - (string= "" a))) - -(defun annotate-annotation-prop-get (annotation property) - "Get property PROPERTY from annotation ANNOTATION. If -ANNOTATION does not pass `annotationp' returns nil." - (annotate-ensure-annotation (annotation) - (overlay-get annotation property))) - -(defun annotate-annotation-get-chain-position (annotation) - "Get property's value that define position of this annotation -in a chain of annotations" - (annotate-annotation-prop-get annotation annotate-prop-chain-position)) - -(defun annotate-annotation-chain-position (annotation pos) - "Set property's value that define position of this annotation -in a chain of annotations." - (overlay-put annotation annotate-prop-chain-position pos)) - -(defun annotate-chain-last-p (annotation) - "Non nil if ANNOTATION is the last element of a chain of annotations." - (let ((value (annotate-annotation-get-chain-position annotation))) - (and value - (cl-equalp value annotate-prop-chain-pos-marker-last)))) - -(defun annotate-chain-first-p (annotation) - "Non nil if ANNOTATION is the first element, or the only -of a chain of annotations." - (let* ((chain-pos (annotate-annotation-get-chain-position annotation)) - (annotation-start (overlay-start annotation)) - (previous-annotation (annotate-previous-annotation-ends annotation-start)) - (previous-chain-pos (annotate-annotation-get-chain-position previous-annotation))) - (or (= chain-pos - annotate-prop-chain-pos-marker-first) - (and (= chain-pos - annotate-prop-chain-pos-marker-last) - (or (null previous-annotation) - (= previous-chain-pos - annotate-prop-chain-pos-marker-last)))))) - -(defun annotate-chain-first (annotation) - "Find first element of the chain where ANNOTATION belongs." - (cond - ((null annotation) - nil) - ((annotate-chain-first-p annotation) - annotation) - (t - (let* ((annotation-start (overlay-start annotation)) - (previous-annotation (annotate-previous-annotation-ends annotation-start))) - (annotate-chain-first previous-annotation))))) - -(defun annotate-chain-last (annotation) - "Find last element of the chain where ANNOTATION belongs." - (cond - ((null annotation) - nil) - ((annotate-chain-last-p annotation) - annotation) - (t - (let* ((annotation-end (overlay-end annotation)) - (next-annotation (annotate-next-annotation-starts annotation-end))) - (annotate-chain-last next-annotation))))) - -(defun annotate-chain-first-at (pos) - "Find first element of the chain of annotation that overlap point POS." - (let ((annotation (annotate-annotation-at pos))) - (annotate-ensure-annotation (annotation) - (annotate-chain-first annotation)))) - -(defun annotate-chain-last-at (pos) - "Find last element of the chain of annotation that overlap point POS." - (let ((annotation (annotate-annotation-at pos))) - (annotate-ensure-annotation (annotation) - (annotate-chain-last annotation)))) - -(defun annotate-chain-at (pos) - "Find the chain of overlays where point POS belongs." - (let ((annotation (annotate-annotation-at pos))) - (annotate-ensure-annotation (annotation) - (annotate-find-chain annotation)))) - -(defun annotate-annotation-set-chain-first (annotation) - "Set property's value that define position of this annotation -in a chain of annotations as first." - (annotate-annotation-chain-position annotation annotate-prop-chain-pos-marker-first)) - -(defun annotate-annotation-set-chain-last (annotation) - "Set property's value that define position of this annotation -in a chain of annotations as last." - (annotate-annotation-chain-position annotation annotate-prop-chain-pos-marker-last)) - -(defun annotate-find-chain (annotation) - "Find all ANNOTATION that are parts of the chain where ANNOTATION belongs." - (annotate-ensure-annotation (annotation) - (cl-labels ((find-next-annotation (pos) - (annotate-annotation-at (next-overlay-change pos)))) - (let* ((chain-first (annotate-chain-first annotation)) - (results (list chain-first)) - (chain-last (annotate-chain-last annotation)) - (start-pos (overlay-end chain-first)) - (next-annotation (find-next-annotation start-pos))) - (if (eq chain-first - chain-last) - results - (while (not (eq next-annotation - chain-last)) - (if next-annotation - (progn - (cl-pushnew next-annotation results) - (setf start-pos (overlay-end next-annotation))) - (cl-incf start-pos)) - (setf next-annotation (find-next-annotation start-pos))) - (push chain-last results) - (reverse results)))))) - -(defun annotate-annotations-chain-at (pos) - "Find all annotation that are parts of the chain that overlaps at POS." - (annotate-find-chain (annotate-annotation-at pos))) - -(defun annotate-chain-hide-text (chain) - "Sets an overlay properties of the last ring of CHAIN so that -the annotation's text will not be rendered." - (let ((last-ring (annotate-chain-last-ring chain))) - (overlay-put last-ring 'hide-text t))) - -(defun annotate-chain-show-text (chain) - "Sets an overlay properties of the last ring of CHAIN so that -the annotation's text will be rendered." - (let ((last-ring (annotate-chain-last-ring chain))) - (overlay-put last-ring 'hide-text nil))) - -(defun annotate-chain-hide-text-p (chain) - "Non nil if the annotation's text contained in the last ring of CHAIN -must not be rendered." - (let ((last-ring (annotate-chain-last (cl-first chain)))) - (annotate-tail-overlay-hide-text-p last-ring))) - -(defun annotate-tail-overlay-hide-text-p (overlay) - "Get the property for hiding the annotation text from OVERLAY." - (overlay-get overlay 'hide-text)) - -(defun annotate-create-annotation (start end annotation-text annotated-text - &optional color-index position) - "Create a new annotation for selected region (from START to END. - -Here the argument ANNOTATION-TEXT is the string that appears -on the margin of the window and ANNOTATED-TEXT is the string -that is underlined. - -If this function is called from procedure -`annotate-load-annotations' the argument ANNOTATED-TEXT -should be not null. In this case we know that an annotation -existed in a text interval defined in the database -metadata (the database located in the file specified by the -variable `annotate-file') and should just be -restored. Sometimes the annotated text (see above) can not be -found in said interval because the annotated file's content -changed and `annotate-mode' could not track the -changes (e.g. save the file when `annotate-mode' was not -active/loaded) in this case the matching -text (\"annotated-text\") is searched in a region surrounding the -interval and, if found, the buffer is annotated right there. - -The searched interval can be customized setting the variable: -\"annotate-search-region-lines-delta\". - -COLOR-INDEX, if non-null (default nil), is used as index to address -elements both in ANNOTATE-COLOR-INDEX-FROM-DUMP -and ANNOTATE-COLOR-INDEX-FROM-DUMP to specify annotation appearance. - -Finally POSITION indicates the positioning policy for the annotation, -if null the value bound to ANNOTATE-ANNOTATION-POSITION-POLICY is -used." - (cl-labels ((face-annotation-shifting-point (position shifting-direction-function) - (when-let* ((annotation (funcall shifting-direction-function - position)) - (annotation-face (annotate-annotation-face annotation))) - (cl-find-if (lambda (a) (cl-equalp annotation-face a)) - annotate-highlight-faces))) - (face-annotation-before-point (position) - (face-annotation-shifting-point position - #'annotate-previous-annotation-ends)) - (face-annotation-after-point (position) - (face-annotation-shifting-point (max (point-min) - (1- position)) - #'annotate-next-annotation-starts)) - (available-face-index (&rest used-faces) - (cl-position-if-not (lambda (a) - (cl-member a used-faces :test #'cl-equalp)) - annotate-highlight-faces)) - (create-annotation (start end annotation-text) - (if (null color-index) - (when-let* ((new-face-index (available-face-index (face-annotation-before-point start) - (face-annotation-after-point end)))) - (setf annotate-colors-index-counter - new-face-index)) - (cl-incf annotate-colors-index-counter)) - (save-excursion - (let ((all-overlays ())) - (while (< start end) - (goto-char start) - (let ((char-maybe-newline (string (char-after)))) - (if (string= char-maybe-newline "\n") - (goto-char (1+ (point))) - (progn - (re-search-forward "\n" end :goto-end) - (when (<= (point) end) - (let* ((end-overlay (if (/= (point) end) - (1- (point)) - (point))) - (highlight (make-overlay start end-overlay)) - (highlight-face (if color-index - (elt annotate-highlight-faces - color-index) - (annotate--current-highlight-face))) - (annotation-face (if color-index - (elt annotate-annotation-text-faces - color-index) - (annotate--current-annotation-text-face)))) - (annotate-annotation-set-face highlight highlight-face) - (annotate-annotation-set-annotation-text highlight annotation-text) - (annotate-annotation-set-annotation-face highlight annotation-face) - (annotate-overlay-maybe-set-position highlight position) - (annotate-overlay-maybe-set-help-echo highlight - annotation-text) - (annotate-annotation-chain-position highlight - annotate-prop-chain-pos-marker-last) - (push highlight all-overlays)))))) - (setf start (point))) - (annotate--remap-chain-pos (reverse (mapcar #'maybe-force-newline-policy - all-overlays)))))) - (beginning-of-nth-line (start line-count) - (save-excursion - (goto-char start) - (forward-line line-count) - (beginning-of-line) - (point))) - (go-backward (start) - (beginning-of-nth-line - start - (- annotate-search-region-lines-delta))) - (go-forward (start) - (beginning-of-nth-line start - annotate-search-region-lines-delta)) - (guess-match-and-add (start end annotated-text max) - (cl-block surrounding - (while (< start max) - (let ((to-match (ignore-errors - (buffer-substring-no-properties start end)))) - (if (and to-match - (string= to-match annotated-text)) - (cl-return-from surrounding start)) - (progn - (setf start (1+ start) - end (1+ end))))) - nil)) - (maybe-force-newline-policy (annotation) - ;; force newline policy if height of any the face of the - ;; overlay is different from height of default face - (save-excursion - (goto-char (overlay-start annotation)) - (let* ((bol (annotate-beginning-of-line-pos)) - (eol (annotate-end-of-line-pos)) - (changed-face-pos (min bol (overlay-start annotation))) - (limit (max eol (overlay-end annotation))) - (all-faces (list (get-text-property changed-face-pos 'face))) - (default-face-height (face-attribute 'default :height)) - (all-faces-height ()) - (force-newline-p nil)) - (while (< changed-face-pos limit) - (setf changed-face-pos - (next-single-property-change changed-face-pos - 'face - (current-buffer) - limit)) - (push (get-text-property changed-face-pos 'face) - all-faces)) - (setf all-faces-height - (mapcar (lambda (face) - (cond - ((facep face) - (face-attribute face :height nil 'default)) - ((and (consp face) - (keywordp (cl-first face))) ; a plist - (cl-getf face :height - (face-attribute 'default :height))) - ((consp face) ; a list of named face, first wins - (face-attribute (cl-first face) :height nil 'default)) - (t - (face-attribute 'default :height)))) - (remq nil all-faces))) - (setf force-newline-p - (cl-find-if (lambda (a) (/= a default-face-height)) - all-faces-height)) - (when force-newline-p - (annotate-annotation-set-position annotation :new-line))) - annotation)) - (next-to-a-line-terminator-p () - (save-excursion - (goto-char end) - (re-search-forward "\n" nil t)))) - (cond - ((annotate-string-empty-p annotation-text) - (signal 'annotate-empty-annotation-text-error t)) - ((and (not (or annotate-use-echo-area - (next-to-a-line-terminator-p))) - (annotate--confirm-append-newline-at-the-end-of-buffer)) - (save-excursion - (goto-char (point-max)) - (insert "\n")) - (annotate-create-annotation start - end - annotation-text - annotated-text - color-index position)) - (t - (if (not (annotate-string-empty-p annotated-text)) - (let ((text-to-match (ignore-errors - (buffer-substring-no-properties start end)))) - (if (and text-to-match - (string= text-to-match annotated-text)) - (create-annotation start end annotation-text) - (let* ((starting-point-matching (go-backward start)) - (ending-point-match (go-forward start)) - (length-match (- end start)) - (new-match (guess-match-and-add starting-point-matching - (+ starting-point-matching - length-match) - annotated-text - ending-point-match))) - (and new-match - (create-annotation new-match - (+ new-match length-match) - annotation-text))) - (lwarn '(annotate-mode) ; if matches annotated text failed - :warning - annotate-warn-file-searching-annotation-failed-control-string - (annotate-actual-file-name) - annotation-text - text-to-match))) - (create-annotation start end annotation-text)) ; create new annotation - (when (use-region-p) - (deactivate-mark)) - (save-excursion - (goto-char end) - (font-lock-fontify-block 1)))))) - -(defun annotate-overlay-put-echo-help (overlay text) - "Set the property `help-echo' to TEXT in overlay OVERLAY." - (overlay-put overlay 'help-echo text)) - -(defun annotate-overlay-get-echo-help (overlay) - "Set the property `help-echo' from overlay OVERLAY." - (overlay-get overlay 'help-echo)) - -(defun annotate-overlay-maybe-set-help-echo (overlay annotation-text) - "Set the property `help-echo' to ANNOTATION-TEXT in overlay OVERLAY if -the annotations should be shown in a popup fashion. - -See the variable: `annotate-use-echo-area'." - (when annotate-use-echo-area - (annotate-overlay-put-echo-help overlay annotation-text))) - -(defun annotate--delete-annotation-chain (annotation) - "Delete ANNOTATION from a buffer and the chain it belongs to. - -This function is not part of the public API." - (annotate-ensure-annotation (annotation) - (save-excursion - (with-current-buffer (current-buffer) - (let* ((chain (annotate-find-chain annotation))) - ;; (filename (annotate-actual-file-name)) - (dolist (single-element chain) - (goto-char (overlay-end single-element)) - (move-end-of-line nil) - (annotate--remove-annotation-property (overlay-start single-element) - (overlay-end single-element)) - (delete-overlay single-element))))))) - -(defun annotate--delete-annotation-chain-ring (annotation-ring) - "Delete overlay of ANNOTATION-RING from a buffer. - -A ring is a single element of an annotation chain. - -This function is not part of the public API." - (annotate-ensure-annotation (annotation-ring) - (save-excursion - (goto-char (overlay-end annotation-ring)) - (move-end-of-line nil) - (annotate--remove-annotation-property (overlay-start annotation-ring) - (overlay-end annotation-ring)) - (delete-overlay annotation-ring)))) - -(defun annotate-delete-chain-element (annotation) - "Delete a ring (a ring is a single element of an ANNOTATION chain.) -from a chain where ANNOTATION belong." - (annotate-ensure-annotation (annotation) - (let* ((chain (annotate-find-chain annotation)) - (first-of-chain-p (annotate-chain-first-p annotation)) - (last-of-chain-p (annotate-chain-last-p annotation)) - (only-element-in-chain-p (= (length chain) 1))) - (annotate--delete-annotation-chain-ring annotation) - (when (not only-element-in-chain-p) - (cond - (first-of-chain-p - (let ((second-annotation (cl-second chain))) - (when (not (annotate-chain-last-p second-annotation)) - (annotate-annotation-set-chain-first second-annotation)))) - (last-of-chain-p - (let ((annotation-before (elt chain (- (length chain) 2)))) - (annotate-annotation-set-chain-last annotation-before)))))))) - -(defun annotate--cut-left-annotation (annotation) - "Trims ANNOTATION exactly one character from the start." - (annotate-ensure-annotation (annotation) - (let* ((chain (annotate-find-chain annotation)) - (first-annotation (annotate-chain-first annotation)) - (chain-start-pos (overlay-start first-annotation)) - (first-annotation-ending-pos (overlay-end first-annotation)) - (new-starting-pos (1+ chain-start-pos))) - (cond - ((>= new-starting-pos - first-annotation-ending-pos) ; delete chain element or entire annotation - (if (= (length chain) - 1) ; the chain is formed by just one element, delete entirely - (annotate--delete-annotation-chain first-annotation) - (annotate-delete-chain-element first-annotation))) ; delete just the first element of the chain - (t - (move-overlay first-annotation new-starting-pos first-annotation-ending-pos)))))) - -(defun annotate--cut-right-annotation (annotation &optional refontify-buffer) - "Trims ANNOTATION exactly one character from the end." - (annotate-ensure-annotation (annotation) - (let* ((chain (annotate-find-chain annotation)) - (last-annotation (annotate-chain-last annotation)) - (last-annotation-ending-pos (overlay-end last-annotation)) - (last-annotation-starting-pos (overlay-start last-annotation)) - (new-ending-pos (1- last-annotation-ending-pos))) - (cond - ((<= new-ending-pos - last-annotation-starting-pos) ; delete chain element or entire annotation - (if (= (length chain) 1) ; the chain is formed by just one element, delete entirely - (annotate--delete-annotation-chain last-annotation) - (progn ; delete just the last element of the chain - (annotate-delete-chain-element last-annotation) - (when refontify-buffer - (font-lock-flush))))) - (t - (move-overlay last-annotation last-annotation-starting-pos new-ending-pos)))))) - -(defun annotate--delete-annotation-chain-prevent-modification (annotation) - "Delete an annotation chain backing up and restoring modification -status of the buffer before deletion occured. - -This function is not part of the public API." - (annotate-ensure-annotation (annotation) - (with-silent-modifications - (annotate--delete-annotation-chain annotation)))) - -(defun annotate--confirm-annotation-delete () - "Prompt user for delete confirmation. -This function is not part of the public API." - (or (not annotate-annotation-confirm-deletion) - (y-or-n-p annotate-confirm-deleting-annotation-prompt))) - -(cl-defun annotate-delete-annotation (&optional (point (point))) - "Command to delete an annotation, POINT is the buffer -position where to look for annotation (default the cursor -point)." - (interactive) - (when-let* ((annotation (annotate-annotation-at point))) - (let* ((delete-confirmed-p (annotate--confirm-annotation-delete))) - (when delete-confirmed-p - (annotate--delete-annotation-chain annotation) - (font-lock-flush))) - (when annotate-autosave - (annotate-save-annotations)))) - -(defun annotate--confirm-append-newline-at-the-end-of-buffer () - "Prompt user for appending newline confirmation. -This function is not part of the public API." - (y-or-n-p (format annotate-confirm-appending-newline-prompt (buffer-name)))) - -(defun annotate-change-annotation (pos) - "Change annotation at POS. If empty, delete annotation." - (let* ((highlight (annotate-annotation-at pos)) - (annotation-text (read-from-minibuffer annotate-annotation-prompt - (annotate-annotation-get-annotation-text highlight)))) - (cl-labels ((change (annotation) - (let ((chain (annotate-find-chain annotation))) - (dolist (single-element chain) - (annotate-overlay-maybe-set-help-echo single-element annotation-text) - (annotate-annotation-set-annotation-text single-element annotation-text))))) - (save-excursion - (cond - ;; annotation was cancelled: - ((null annotation-text)) - ;; annotation was erased: - ((string= "" annotation-text) - (let* ((delete-confirmed-p (annotate--confirm-annotation-delete))) - (when delete-confirmed-p - (annotate--delete-annotation-chain-prevent-modification highlight)))) - ;; annotation was changed: - (t - (change highlight))))))) - -(defun annotate-make-prefix () - "An empty string from the end of the line upto the annotation." - (save-excursion - (let* ((line-text (buffer-substring - (progn (beginning-of-line) (point)) - (progn (end-of-line) (point)))) - (prefix-length (- annotate-annotation-column (string-width line-text)))) - (if (< prefix-length 1) - (concat " \n" (make-string annotate-annotation-column ? )) - (make-string prefix-length ? ))))) - -(defun annotate-annotation-at (pos) - "Return the annotations (overlay where (annotationp overlay) -> t) -at positions POS or nil if no annotations exists at pos. - -NOTE this assumes that annotations never overlaps so the list of -all annotations can contains only one element maximum." - (let ((all (cl-remove-if-not #'annotationp - (overlays-at pos)))) - (cl-first all))) - -(defun annotate-previous-annotation-ends (pos) - "Return the previous annotation that ends before POS or nil if no annotation -was found. -NOTE this assumes that annotations never overlaps." - (cl-labels ((previous-annotation-ends (start) - (let ((annotation (annotate-annotation-at start))) - (while (and (> start - (point-min)) - (null annotation)) - (setf start (previous-overlay-change start)) - (setf annotation (annotate-annotation-at start))) - annotation))) - (let ((annotation (annotate-annotation-at pos))) - (if annotation - (previous-annotation-ends (1- (overlay-start annotation))) - (previous-annotation-ends pos))))) - -(defun annotate-previous-annotation (annotation) - "Return the annotation before ANNOTATIONS or nil if no such -annotation exists." - (annotate-previous-annotation-ends (overlay-start (annotate-chain-first annotation)))) - -(defun annotate-next-annotation-starts (pos) - "Return the next annotation that starts after POS or nil if no annotation -was found. -NOTE this assumes that annotations never overlaps." - (cl-labels ((next-annotation-ends (start) - (let ((annotation (annotate-annotation-at start))) - (while (and (/= start - (point-max)) - (null annotation)) - (setf start (next-overlay-change start)) - (setf annotation (annotate-annotation-at start))) - annotation))) - (let ((annotation (annotate-annotation-at pos))) - (if annotation - (next-annotation-ends (overlay-end annotation)) - (next-annotation-ends pos))))) - -(defun annotate-next-annotation (annotation) - "Return the annotation after ANNOTATIONS or nil if no such -annotation exists." - (annotate-next-annotation-starts (overlay-end (annotate-chain-last annotation)))) - -(defun annotate-symbol-strictly-at-point () - "Return non nil if a symbol is at char immediately following -the point. This is needed as `thing-at-point' family of - functions returns non nil if the thing (a symbol in this case) - is around the point, according to the documentation." - (cl-labels ((after-point () - (save-excursion - (goto-char (1+ (point))) - (bounds-of-thing-at-point 'symbol)))) - (let ((sym-on-point (bounds-of-thing-at-point 'symbol)) - (sym-after-point (after-point))) - (and sym-on-point - sym-after-point - (cl-equalp sym-on-point - sym-after-point))))) - -(defun annotate-bounds () - "The bounds of the region or whatever is at point." - (cl-labels ((left-ends () - (cond - ((use-region-p) - (region-beginning)) - ((annotate-symbol-strictly-at-point) - (let* ((annotation-before (annotate-previous-annotation-ends (point))) - (boundaries (bounds-of-thing-at-point 'symbol)) - (symbol-start (car boundaries)) - (annotation-end (if annotation-before - (overlay-end annotation-before) - -1))) - (max symbol-start - annotation-end))) - (t - (point)))) - (right-ends () - (cond - ((use-region-p) - (if (and (char-before (region-end)) - (char-equal (char-before (region-end)) - ?\n)) - (1- (region-end)) - (region-end))) - ((annotate-symbol-strictly-at-point) - (let* ((annotation-after (annotate-next-annotation-starts (point))) - (boundaries (bounds-of-thing-at-point 'symbol)) - (symbol-end (cdr boundaries)) - (annotation-start (if annotation-after - (overlay-start annotation-after) - (1+ symbol-end)))) - (min symbol-end - annotation-start))) - (t - (1+ (point)))))) - (list (left-ends) - (right-ends)))) - -(defun annotate-make-annotation (beginning ending annotation annotated-text) - "Make an annotation record that represent an annotation -starting at BEGINNING, terminate at ENDING with annotation -content ANNOTATION and annotated text ANNOTATED-TEXT." - (list beginning ending annotation annotated-text)) - -(defun annotate-all-annotations () - "Return a list of all annotations in the current buffer." - (cl-remove-if-not #'annotationp (overlays-in 0 (buffer-size)))) - -(defun annotate-describe-annotations () - "Return a list of all annotations in the current buffer. -The format is suitable for database dump." - (let ((all-annotations (cl-remove-if-not #'annotationp (overlays-in 0 (buffer-size)))) - (chain-visited ())) - (remq nil - (mapcar (lambda (annotation) - (let* ((chain (annotate-find-chain annotation)) - (chain-first (annotate-chain-first annotation)) - (chain-last (annotate-chain-last annotation)) - (from (overlay-start chain-first)) - (to (overlay-end chain-last)) - (face (annotate-annotation-face chain-first)) - (color-index (cl-position-if (lambda (a) (cl-equalp face a)) - annotate-highlight-faces)) - (position (annotate-annotation-get-position annotation))) - (when (not (cl-find-if (lambda (a) - (eq (cl-first chain) - (cl-first a))) - chain-visited)) - (push chain chain-visited) - (list from - to - (annotate-annotation-get-annotation-text annotation) - (buffer-substring-no-properties from to) - color-index - position)))) - all-annotations)))) - -(defun annotate-info-root-dir-p (filename) - "Is the name of this file (FILENAME) equals to the info root node?" - (string= filename - annotate-info-root-name)) - -(defun annotate-guess-file-format (filename) - "Try to guess the file format from FILENAME. -Non nil if the file format is supported from \"annotate\" in a more -sophisticated way than plain text." - (cl-labels ((file-contents () - (with-temp-buffer - (insert-file-contents filename) - (buffer-string))) - (info-format-p () ; lot of guesswork here :( - (cond - ((annotate-info-root-dir-p filename) - :info) - (t - (let* ((file-contents (file-contents)) - (has-info-p (string-match "info" filename)) - (separator-re "\^L?\^_\^L?\^J") - (has-separator-p (string-match separator-re file-contents)) - (has-node-p (string-match "Node:" file-contents))) - (if (and has-separator-p - (or has-node-p - has-info-p)) - :info - nil))))) - (gpg-format-p () - (with-temp-buffer - (let* ((magic-0 #x8c) - (magic-1 #x0d) - (magic-4 #x03) - (magic-5 #x02) - (attributes (file-attributes filename)) - (file-size (file-attribute-size attributes))) - (when (> file-size 6) - (let* ((bytes (insert-file-contents-literally filename - nil - 0 - 7))) - (setf bytes - (cl-loop for i from 1 to 6 collect - (elt (buffer-substring-no-properties i (1+ i)) - 0))) - (when (and (= (logand (elt bytes 0) #x0000ff) magic-0) - (= (logand (elt bytes 1) #x0000ff) magic-1) - (= (logand (elt bytes 4) #x0000ff) magic-4) - (= (logand (elt bytes 5) #x0000ff) magic-5)) - :encrypted-symmetric))))))) - (or (gpg-format-p) - (info-format-p)))) ;; keep this one for last as it is the slowest - -;;;; summary window procedures - -(define-button-type 'annotate-summary-show-annotation-button - 'follow-link t - 'help-echo "Click to show") - -(define-button-type 'annotate-summary-delete-annotation-button - 'follow-link t - 'help-echo "Click to remove annotation") - -(define-button-type 'annotate-summary-replace-annotation-button - 'follow-link t - 'help-echo "Click to replace annotation") - -(defun annotate-info-setup (file-or-node buffer) - "Display Info node FILE-OR-NODE in BUFFER. - -Compatibility wrapper for the function `info-setup' and `info-pop-to-buffer'." - (with-no-warnings - (if (version< "30" emacs-version) - (info-pop-to-buffer file-or-node buffer) - (info-setup file-or-node buffer)))) - -(defun annotate-summary-show-annotation-button-pressed (button) - "Callback called when an annotate-summary-show-annotation-button is activated." - (let* ((file (button-get button 'file)) - (file-type (annotate-guess-file-format file))) - (cond - ((eq file-type :info) - (with-current-buffer-window - "*info*" nil nil - (annotate-info-setup file (current-buffer)) - (switch-to-buffer "*info*")) - (with-current-buffer "*info*" - (goto-char (button-get button 'go-to)))) - (t - (let* ((buffer (find-file-other-window file))) - (with-current-buffer buffer - (goto-char (button-get button 'go-to)))))))) - -(defun annotate-update-visited-buffer-maybe (filename) - "Reload annotation mode in the buffer visiting FILENAME, if such buffer exists." - (let ((visited-buffer (find-buffer-visiting filename))) - (when visited-buffer ;; a buffer is visiting the file - (with-current-buffer visited-buffer - (annotate-mode -1) - (annotate-mode 1))))) - -(defun annotate-summary-delete-annotation-button-pressed (button) - "Callback for summary window fired when a \"delete\" button is -pressed." - (let* ((filename (button-get button 'file)) - (beginning (button-get button 'beginning)) - (ending (button-get button 'ending)) - (db (annotate-load-annotation-data t)) - (filtered (annotate-db-remove-annotation db filename beginning ending))) - (annotate-dump-annotation-data filtered) ; save the new database with entry removed - (cl-labels ((redraw-summary-window () ; update the summary window - (with-current-buffer annotate-summary-buffer-name - (read-only-mode -1) - (save-excursion - (button-put button 'invisible t) - (let ((annotation-button (previous-button (point)))) - (button-put annotation-button 'face '(:strike-through t))) - (let ((replace-button (next-button (point)))) - (button-put replace-button 'invisible t))) - (read-only-mode 1)))) - (redraw-summary-window) - (annotate-update-visited-buffer-maybe filename)))) - -(defun annotate-summary-replace-annotation-button-pressed (button) - "Callback for summary window fired when a \"replace\" button is -pressed." - (let* ((filename (button-get button 'file)) - (annotation-beginning (button-get button 'beginning)) - (annotation-ending (button-get button 'ending)) - (query (button-get button 'query)) - (db (annotate-load-annotation-data t)) - (old-annotation (button-get button 'text)) - (new-annotation-text (read-from-minibuffer annotate-annotation-prompt old-annotation))) - (when (not (annotate-string-empty-p new-annotation-text)) - (let ((replaced-annotation-db (annotate-db-replace-annotation db - filename - annotation-beginning - annotation-ending - new-annotation-text))) - (annotate-dump-annotation-data replaced-annotation-db) - (annotate-update-visited-buffer-maybe filename) - (annotate-show-annotation-summary query nil nil))))) - -(cl-defun annotate-wrap-text (text &optional (wrapper "\"")) - "Wrap string TEXT with string WRAPPER." - (concat wrapper text wrapper)) - -(cl-defun annotate-unwrap-text (text &optional (wrapper "\"") (left-side t)) - "Remove WRAPPER at both ends from TEXT." - (let ((results text) - (wrapper-length (length wrapper))) - (when (>= (length text) - wrapper-length) - (if left-side - (let ((maybe-wrapper (substring results 0 wrapper-length))) - (when (string= maybe-wrapper wrapper) - (setf results (substring results wrapper-length)) - (setf results (annotate-unwrap-text results wrapper nil)))) - (let ((maybe-wrapper (substring results - (- (length results) - wrapper-length)))) - (when (string= maybe-wrapper wrapper) - (setf results (substring results 0 (- (length results) - wrapper-length))))))) - results)) - -(cl-defun annotate-show-annotation-summary (&optional arg-query cut-above-point (save-annotations t)) - "Show a summary of all the annotations in a temp buffer, the -results can be filtered with a simple query language: see -`annotate-summary-filter-db'." - (interactive) - (cl-labels ((ellipsize (text prefix-string) - (let* ((prefix-length (string-width prefix-string)) - (ellipse-length (string-width annotate-ellipse-text-marker)) - (substring-limit (max 0 - (- (window-body-width) - prefix-length - ellipse-length - 2)))) ; this is for quotation marks - (if (> (string-width text) - substring-limit) - (concat (substring text 0 substring-limit) - annotate-ellipse-text-marker) - text))) - (wrap (text) - (annotate-wrap-text text "\"")) - (insert-item-summary (filename - snippet-text - button-text - annotation-beginning - annotation-ending - filter-query) - (insert annotate-summary-list-prefix-snippet) - (insert (wrap (ellipsize snippet-text - annotate-summary-list-prefix-snippet))) - (insert "\n") - (insert annotate-summary-list-prefix) - (insert-button (propertize (ellipsize button-text - annotate-summary-list-prefix) - 'face - 'bold) - 'file filename - 'go-to annotation-beginning - 'action 'annotate-summary-show-annotation-button-pressed - 'type 'annotate-summary-show-annotation-button) - (insert "\n\n") - (insert annotate-summary-list-prefix) - (insert " ") - (let ((del-button (insert-button - annotate-summary-delete-button-label - 'file filename - 'beginning annotation-beginning - 'ending annotation-ending - 'action - 'annotate-summary-delete-annotation-button-pressed - 'type - 'annotate-summary-delete-annotation-button))) - (button-put del-button - 'begin-of-button - (annotate-beginning-of-line-pos)) - (button-put del-button - 'end-of-button - (annotate-end-of-line-pos))) - (insert "\n") - (insert annotate-summary-list-prefix) - (insert " ") - (insert-button annotate-summary-replace-button-label - 'file filename - 'beginning annotation-beginning - 'ending annotation-ending - 'query filter-query - 'text button-text - 'action - 'annotate-summary-replace-annotation-button-pressed - 'type - 'annotate-summary-replace-annotation-button) - (insert "\n\n")) - (clean-snippet (snippet) - (save-match-data - (replace-regexp-in-string "[\r\n]" - " " - snippet))) - (build-snippet-info (filename annotation-begin annotation-end) - (with-temp-buffer - (annotate-info-setup filename (current-buffer)) - (buffer-substring-no-properties annotation-begin - annotation-end))) - (build-snippet-from-buffer (filename annotation-begin annotation-end) - (let ((visited-buffer (find-buffer-visiting filename))) - (when visited-buffer ;; a buffer is visiting the file - (with-current-buffer visited-buffer - (let ((raw-snippet (buffer-substring-no-properties annotation-begin - annotation-end))) - (clean-snippet raw-snippet)))))) - (build-snippet-from-file (filename annotation-begin annotation-end) - (with-temp-buffer - (insert-file-contents filename - nil - (1- annotation-begin) - (1- annotation-end)) - (clean-snippet (buffer-string)))) - (build-snippet (filename annotation-begin annotation-end) - (if (file-exists-p filename) - (cond - ((eq (annotate-guess-file-format filename) - :info) - (clean-snippet (build-snippet-info filename - annotation-begin - annotation-end))) - (t - (or (build-snippet-from-buffer filename - annotation-begin - annotation-end) - (build-snippet-from-file filename - annotation-begin - annotation-end)))) - (if (annotate-info-root-dir-p filename) - (clean-snippet (build-snippet-info filename - annotation-begin - annotation-end)) - annotate-error-summary-win-filename-invalid))) - (db-empty-p (dump) - (cl-every (lambda (a) - (cl-every #'null - (annotate-annotations-from-dump a))) - dump)) - (get-query () - (cond - (arg-query - arg-query) - (annotate-summary-ask-query - (read-from-minibuffer "Query: ")) - (t - ".*")))) - (when save-annotations - (annotate-save-all-annotated-buffers)) - (let* ((filter-query (get-query)) - (dump (annotate-summary-filter-db (annotate-load-annotation-data t) - filter-query - cut-above-point))) - (if (db-empty-p dump) - (when annotate-use-messages - (message "The annotation database is empty")) - (with-current-buffer-window - annotate-summary-buffer-name nil nil - (display-buffer annotate-summary-buffer-name) - (select-window (get-buffer-window annotate-summary-buffer-name t)) - (outline-mode) - (use-local-map nil) - (local-set-key "q" (lambda () - (interactive) - (kill-buffer annotate-summary-buffer-name))) - (dolist (annotation dump) - (let* ((all-annotations (annotate-annotations-from-dump annotation)) - (db-filename (annotate-filename-from-dump annotation))) - (when (not (null all-annotations)) - (insert (format (concat annotate-summary-list-prefix-file "%s\n\n") - db-filename)) - (dolist (annotation-field all-annotations) - (let* ((button-text (format "%s" - (annotate-annotation-string annotation-field))) - (annotation-begin (annotate-beginning-of-annotation annotation-field)) - (annotation-end (annotate-ending-of-annotation annotation-field)) - (snippet-text (build-snippet db-filename - annotation-begin - annotation-end))) - (insert-item-summary db-filename - snippet-text - button-text - annotation-begin - annotation-end - filter-query)))))) - (read-only-mode 1)))))) - -;;;; end summary window procedures - -;;;; filtering summary window: parser, lexer, etc. - -(defvar annotate-summary-query nil - "Holds the query to filter annotations when -summary window is shown.") - -(defvar annotate-summary-query-current-token nil - "Holds the next token of the query in `annotate-summary-query'.") - -(defun annotate-summary-query-lexer-symbol (res) - "The symbol identifying the token (e.g. \\='and)." - (elt res 0)) - -(defun annotate-summary-query-lexer-string (res) - "The string associated with this token." - (elt res 1)) - -(defun annotate-summary-query-lexer-start (res) - "The starting point of the substring of -`annotate-summary-query' for this token." - (elt res 2)) - -(defun annotate-summary-query-lexer-end (res) - "The ending point of the substring of -`annotate-summary-query' for this token." - - (elt res 3)) - -(cl-defun annotate-summary-lexer (&optional (look-ahead-p nil)) - "The lexer for `annotate-summary-query'. - -This function, when called, will produce the next token from -`annotate-summary-query'; a token is a substring with a well -defined meaning according to our grammar. - -For example this string: - -p.* and (a or not b) - -will be broken into these tokens: - -\\='(re \"p.*\" 0 3) -\\='(and \"and\" 4 7) -\\='(open-par \"(\" 8 9) -\\='(re \"a\" 9 10) -\\='(or \"or\" 11 12) -\\='(not \"not\" 14 17) -\\='(re \"b\" 18 19) -\\='(close-par \"(\" 19 20) - -The format is a proper list where: -- first element - a symbol representing the type of the token - - \\='re = regular expression - - \\='and , \\='or , \\='not = logical operator - - \\='open-par, \\='close-par = open and closing parenthesis respectively -- second element - the value (the actual substring for this token) - -- third and fourth element (currently unused) - the substring limits for this token (as returned by - MATCH-BEGINNING and MATCH-END. - -Note that spaces are ignored and all the tokens except \"re\" must -not be prefixed with a backslash to match. So, for example not -> -will match the token type \\='not but \not will match the token \\='re; -this way we can \"protect\" a regexp that contains reserved -keyword (aka escaping). - -The special value :no-more-token is returned after the whole -input is processed. - -Calling this function with value of LOOK-AHEAD-P nil will consume the -token from `annotate-summary-query' (i.e. that string is modified). - -example: -\"a and b\" -> \"and b\", \\='(re \"a\" 0 1) - -when LOOK-AHEAD-P is not nil the token is recognized but not cut away -from `annotate-summary-query'. - -example: -\"a and b\" -> \"a and b\", \\='(re \"a\" 0 1)" - (cl-labels ((build-token (token-symbol token-string token-beginning token-end) - (list token-symbol - token-string - token-beginning - token-end)) - (build-results (token-symbol register-num) - (build-token token-symbol - (match-string register-num annotate-summary-query) - (match-beginning register-num) - (match-end register-num))) - (cut-query (match-results) - (setf annotate-summary-query - (cl-subseq annotate-summary-query - (annotate-summary-query-lexer-end match-results))))) - (let ((re (concat "\\((\\)\\|\\()\\)\\|\\(and\\)\\|\\(not\\)\\|" - "\\(or\\)\\|\\(\".*\"\\)\\|\\([^[:space:]]+\\)"))) - (save-match-data - (let* ((matchedp (string-match re annotate-summary-query)) - (res (if matchedp - (cond - ((match-string 1 annotate-summary-query) - (build-results 'open-par 1)) - ((match-string 2 annotate-summary-query) - (build-results 'close-par 2)) - ((match-string 3 annotate-summary-query) - (build-results 'and 3)) - ((match-string 4 annotate-summary-query) - (build-results 'not 4)) - ((match-string 5 annotate-summary-query) - (build-results 'or 5)) - ((match-string 6 annotate-summary-query) - (build-results 'escaped-re 6)) - ((match-string 7 annotate-summary-query) - (build-results 're 7)) - (t - :no-more-tokens)) - :no-more-tokens))) - (when (and (listp res) - (not look-ahead-p)) - (cut-query res)) - res))))) - -(defun annotate-summary-query-parse-end-input-p (token) - "Non nil if there are no more tokens in `annotate-summary-query'." - (eq token :no-more-tokens)) - -(defun annotate-summary-token-symbol-match (looking-symbol token) - "Return non nil if LOOKING-SYMBOL is \"eq\" to the symbol -component of TOKEN." - (eq looking-symbol - (annotate-summary-query-lexer-symbol token))) - -(cl-defun annotate-summary-query-parse-note (filter-fn annotation &optional (res nil)) - "Parser rule for note: - -This function will parse the following production rules - -NOTE := \"(\" NOTE \")\" - | NOTE OPERATOR NOTE - | NOT NOTE - | RE - | ESCAPED-RE - | epsilon -OPERATOR := AND | OR -FILE-MASK := RE -RE := [^[:space:]] ; as regular expression -ESCAPED-RE := DELIMITER - ANYTHING - DELIMITER -ANYTHING := .* ; as a regular expression -AND := \"and\" -OR := \"or\" -NOT := \"not\" -DELIMITER := \" ; ASCII 34 (dec) 22 (hex) - -Arguments: - -- filter-fn is a function that accept two parameters: the regular - expression to match (a token of type \\='re, see the lexer - `annotate-summary-lexer' and a single annotation record (see - `annotate-load-annotations`). - - This function will reject (its value is nil) records that do - not match the annotation. - -- annotation - the annotation to test - -- res the results of this production rule (internal use only)." - (cl-labels ((token-symbol-match-p (looking-symbol token) - (annotate-summary-token-symbol-match looking-symbol token)) - ;; this function will parse the rule operator - ;; OPERATOR := AND | OR - ;; NOTE OPERATOR NOTE - ;; filter-fn see the docstring - ;; matchp non nil if (funcall filter-fn previous-token) is not nil - (operator (filter-fn annotation matchp) - (let ((look-ahead (annotate-summary-lexer t))) - (if (annotate-summary-query-parse-end-input-p look-ahead) - ;; end of input, recurse one more time - (annotate-summary-query-parse-note filter-fn - annotation - matchp) - (let ((look-ahead-symbol - (annotate-summary-query-lexer-symbol look-ahead)) - (look-ahead-string - (annotate-summary-query-lexer-string look-ahead))) - (cond - ((not (cl-find look-ahead-symbol '(and or close-par))) - (signal 'annotate-query-parsing-error - (list (format (concat "Expecting for operator " - "('and' or 'or') or \")\". " - "found %S instead") - look-ahead-string)))) - (t - ;; found operator, recurse to search for rhs of rule - ;; NOTE OPERATOR NOTE - (annotate-summary-query-parse-note filter-fn - annotation - matchp)))))))) - (let* ((look-ahead (annotate-summary-lexer t))) ; the next token that the lexer *will* consume - ; note the second arg is non nil - (if (not (annotate-summary-query-parse-end-input-p look-ahead)) - (progn - (cond - ((token-symbol-match-p 'close-par look-ahead) ; ignore closing parens - res) - ((token-symbol-match-p 'open-par look-ahead) ; next token is an open parens - ;; trying to match the rule: - ;; NOTE := '(' NOTE ')' - (annotate-summary-lexer) ; consume the token ')' - ;; match the note inside the parens - (let ((matchp (annotate-summary-query-parse-note filter-fn - annotation)) ; recurse - ;; after the note there *must* be a closing parenthesis - (maybe-close-parens (annotate-summary-lexer))) - ;; if not this is an error - (when (or (annotate-summary-query-parse-end-input-p maybe-close-parens) - (not (eq (annotate-summary-query-lexer-symbol maybe-close-parens) - 'close-par))) - (signal 'annotate-query-parsing-error '("Unmatched parens"))) - ;; continue parsing - (annotate-summary-query-parse-note filter-fn annotation matchp))) ; recurse - ((token-symbol-match-p 'not look-ahead) - (annotate-summary-lexer) ; consume the token 'not' - ;; the note after the 'not' operator in rule - ;; NOTE := NOT NOTE - ;; the third argument is the value to return if - ;; there are no more token left in the input string - (let ((res (annotate-summary-query-parse-note filter-fn annotation :error))) ; recurse - ;; if there are no more tokens here this is an error - ;; because, according to the grammar, after a NOT a - ;; NOTE is non optional - (if (eq :error res) - (signal 'annotate-query-parsing-error '("No more input after 'not'")) - ;; if the last rule (saved in res) is not nil (and - ;; is not :error) return nil, return the last - ;; annotation otherwise remember that the user asked - ;; for an annotation that *not* matches a regex - (if (null res) - annotation - nil)))) - ;; trying to match the rule: - ;; NOTE := NOTE AND NOTE - ((token-symbol-match-p 'and look-ahead) - (annotate-summary-lexer) ; consume the 'and' token - (let ((lhs res) ; the left side of this rule lhs AND rhs - (rhs (annotate-summary-query-parse-note filter-fn annotation :error))) ; recurse - (if (eq :error rhs) ; see the 'not' operator above - (signal 'annotate-query-parsing-error '("No more input after 'and'")) - (and lhs rhs)))) ; both rules must match as this is a logic and - ;; trying to match the rule: - ;; NOTE := NOTE OR NOTE - ((token-symbol-match-p 'or look-ahead) - (annotate-summary-lexer) ; consume the 'or' - (let ((lhs res) ; the left side of this rule (lhs OR rhs) - (rhs (annotate-summary-query-parse-note filter-fn annotation :error))) ; recurse - (if (eq :error rhs) - (signal 'annotate-query-parsing-error '("No more input after 'or'")) - (or lhs rhs)))) ; either lhs or rhs match as this is a logic or - ((token-symbol-match-p 'escaped-re look-ahead) - ;; here we match the rule: - ;; NOTE := ESCAPED-RE - ;; ESCAPED-RE is a delimited string like "foo bar" - ;; we first unescape the protected token - ;; "\"foo bar\"" -> "foo bar" (yes, just remove the delimiters) - ;; then we apply the filter function (see the docstring) - (let* ((escaped (annotate-summary-query-lexer-string (annotate-summary-lexer))) - (unescaped (substring escaped 1 (1- (length escaped)))) ; remove delimiters - (matchp (funcall filter-fn unescaped annotation))) ; apply the filter function - ;; and finally continue the parsing saving the results - ;; of applying the filter-fn function - (operator filter-fn annotation matchp))) - (t - ;; here we match the rule: - ;; NOTE := RE - ;; RE := a regular expression - ;; first just get the RE token - (let* ((regex (annotate-summary-query-lexer-string (annotate-summary-lexer))) - ;; then apply the filter function (see the docstring) - (matchp (funcall filter-fn regex annotation))) - ;; and finally continue the parsing saving the results - ;; of applying the filter-fn function - (operator filter-fn annotation matchp))))) - ;; if we are here the lexer can not find any more tokens in the query - ;; just return the value of res - res)))) ; end of '(if (not (annotate-summary-query-parse-end-input-p look-ahead))' - -(defun annotate-summary-query-parse-expression () - "Parse rule for expression: - -I feel this is very likely wrong in many ways, i hope linguists -are going to forgive me :-) - -EXPRESSION := FILE-MASK - | FILE-MASK AND NOTE - | FILE-MASK OR NOTE - | epsilon -NOTE := \"(\" NOTE \")\" - | NOTE OPERATOR NOTE - | NOT NOTE - | RE - | ESCAPED-RE - | epsilon -OPERATOR := AND | OR -FILE-MASK := RE -RE := [^[:space:]] ; as a regular expression -ESCAPED-RE := DELIMITER - ANYTHING - DELIMITER -ANYTHING := .* ; as a regular expression -AND := \"and\" -OR := \"or\" -NOT := \"not\" -DELIMITER := \" ; ASCII 34 (dec) 22 (hex) - -Note: this function returns the annotation part of the record, see -`annotate-load-annotations'." - (lambda (annotation query file-filter-fn note-filter-fn) - (let ((annotate-summary-query query) ; save the query - (query-notes-only nil)) ; the query for just the notes - (let ((next-token (annotate-summary-lexer))) ; get potential file-mask - ;; if there are no more tokens just return all the records - ;; these match the empty string as in rule - ;; EXPRESSION := epsilon - (if (annotate-summary-query-parse-end-input-p next-token) - (annotate-annotations-from-dump annotation) - ;; otherwise test the record with the file-mask - (let* ((quoted-file-mask-p (annotate-summary-token-symbol-match 'escaped-re - next-token)) - (file-mask-raw (annotate-summary-query-lexer-string next-token)) - (file-mask (if quoted-file-mask-p - (annotate-unwrap-text file-mask-raw "\"") - file-mask-raw)) - (filtered-annotation (funcall file-filter-fn file-mask annotation)) - ;; get the operator as in rule - (operator-token (annotate-summary-lexer))) - ;; if there are no operator just return the filtered (by file-mask) - ;; as in rule - ;; EXPRESSION := FILE-MASK - (if (annotate-summary-query-parse-end-input-p operator-token) - (annotate-annotations-from-dump filtered-annotation) - ;; otherwise get the operator and continue to parse the rule - ;; EXPRESSION := FILE-MASK AND NOTE - ;; or - ;; EXPRESSION := FILE-MASK OR NOTE - (let ((operator (annotate-summary-query-lexer-symbol operator-token))) - (cond - ((eq operator 'or) ; operator is 'or - ;; try to parse with the rule - ;; EXPRESSION := FILE-MASK OR NOTE - ;; return only the list annotation filtered by - ;; file-mask the former is non nil - (if filtered-annotation - (annotate-annotations-from-dump filtered-annotation) - ;; the annotation filtered by file-mask is empty, try to - ;; match the NOTE rule - (let ((look-ahead (annotate-summary-lexer t))) - ;; no more input after operator this is wrong - ;; according to the rule we are trying to match: - ;; EXPRESSION := FILE-MASK OR NOTE - (if (annotate-summary-query-parse-end-input-p look-ahead) - (signal 'annotate-query-parsing-error '("No more input after 'or'")) - (progn - ;; copy the string for note parsing note - ;; that annotate-summary-query only contains - ;; the substring to match the NOTE rule - (setf query-notes-only (concat annotate-summary-query)) - ;; parse all the annotations, we get a list - ;; where non nil elements are the annotation - ;; that passes the note-filter-fn test - (mapcar (lambda (a) - (let ((annotate-summary-query (concat query-notes-only))) - (annotate-summary-query-parse-note note-filter-fn - a))) - (annotate-annotations-from-dump annotation))))))) - ((eq operator 'and) - ;; try to parse with the rule - ;; EXPRESSION := FILE-MASK OR NOTE - (let ((look-ahead (annotate-summary-lexer t))) - ;; no more input after operator, this is wrong - ;; according to the rule we are trying to match: - ;; EXPRESSION := FILE-MASK AND NOTE - (if (annotate-summary-query-parse-end-input-p look-ahead) - (signal 'annotate-query-parsing-error '("No more input after 'and'")) - (progn - ;; copy the string for note parsing note - ;; that annotate-summary-query only contains - ;; the substring to match the NOTE rule - (setf query-notes-only (concat annotate-summary-query)) - ;; parse the already filtered by file-mask annotations only - ;; we get a list where non nil elements are the annotation - ;; that passes the note-filter-fn test - (mapcar (lambda (a) - (let ((annotate-summary-query (concat query-notes-only))) - (annotate-summary-query-parse-note note-filter-fn - a))) - (annotate-annotations-from-dump filtered-annotation)))))) - (t - ;; there is something after the file-mask in the - ;; input but it is not an operator - (signal 'annotate-query-parsing-error - (list (format "Unknown operator: %s is not in '(and, or)" - (annotate-summary-query-lexer-string operator-token)))))))))))))) - -(defun annotate-summary-filter-db (annotations-dump query remove-annotations-cutoff-point) - "Filter an annotation database with a query. - -The argument QUERY is a string that respect a simple syntax: - -- [file-mask] [(and | or) [not] regex-note [(and | or) [not] regexp-note ...]] - -where - -- file-mask: is a regular expression that should match the filepath - the annotation refers to; -- and, or, not : you guess? Classics logical operators; -- regex-note: the text of annotation must match this regular expression. - -Examples: - -- lisp$ and TODO - matches the text \"TODO\" in all lisp files - -Parenthesis can be used for the expression related to the text of -annotation, like this: - -- lisp$ and (TODO or important) - the same as above but checks also for string \"important\" - -- /home/foo/ - matches all the annotation that refers to file in the directory - '/home/foo' - -- /home/foo/ and not minor - matches all the annotation that refers to file in the directory - '/home/foo' and that not contains the text \"minor\". - -- .* and \"not\" - the \" can be used to escape strings - -If you want to remove from summary the annotations that appears -before a position in buffer set \"remove-annotations-cutoff-point\" to said -position. - -The annotations in each record are sorted by starting point in ascending order." - (let* ((parser (annotate-summary-query-parse-expression)) - (filter-file (lambda (file-mask annotation-dump) - (let ((filename - (annotate-filename-from-dump annotation-dump))) - (and (string-match-p file-mask filename) - annotation-dump)))) - (filter-annotations (lambda (re annotation-dump-2) - (and (string-match-p re - (annotate-annotation-string annotation-dump-2)) - annotation-dump-2))) - (filter (lambda (single-annotation) - (let ((filtered-annotations (funcall parser - single-annotation - query - filter-file - filter-annotations))) - (setf filtered-annotations - (remq nil filtered-annotations)) - (when filtered-annotations - (let ((filename (annotate-filename-from-dump - single-annotation)) - (checksum (annotate-checksum-from-dump - single-annotation))) - (setf filtered-annotations - (sort filtered-annotations - #'annotate-db-annotations-starts-before-p)) - (when remove-annotations-cutoff-point - (setf filtered-annotations - (cl-remove-if (lambda (a) - (< (annotate-ending-of-annotation a) - remove-annotations-cutoff-point)) - filtered-annotations))) - (annotate-make-annotation-dump-entry filename - filtered-annotations - checksum)))))) - (filtered (remq nil (mapcar filter annotations-dump)))) - filtered)) - -;;;; end of filtering: parser, lexer, etc. - -;;;; misc commands - -(defun annotate-summary-of-file-from-current-pos () - "Shows a summary window that contains only the annotations in -the current buffer and that starts after the current cursor's -position." - (interactive) - (with-current-buffer (current-buffer) - (when buffer-file-name - (annotate-show-annotation-summary (annotate-wrap-text buffer-file-name "\"") - (point))))) - -;;; switching database - -(defun annotate-buffers-annotate-mode () - "Return a list of all the buffers that have -annotate minor mode active." - (let ((all-buffers (buffer-list))) - (cl-labels ((annotate-mode-p (buffer) - (with-current-buffer buffer - (and (boundp 'annotate-mode) ;FIXME: Redundant test? - annotate-mode)))) - (cl-remove-if-not #'annotate-mode-p all-buffers)))) - -(cl-defun annotate-switch-db (&optional (force-load nil) (database-file-path nil)) - "Ask the user for a new annotation database files, load it and -refresh all the annotations contained in each buffer where -annotate minor mode is active. - -if DATABASE-FILE-PATH is nil (the default) a prompt asking for -a file containing database is presented to the user, otherwise -the value of this argument is used. - -If FORCE-LOAD is non nil no prompt asking user for confirmation -about loading the new file is shown. - -Note: this function will attempt to load (compile and -eval/execute) the content of the file as it was elisp source -code, always use load files from trusted sources!" - (interactive) - (let ((new-db (or database-file-path - (read-file-name "Database file location: ")))) - (when (not (annotate-string-empty-p new-db)) - (if (file-exists-p new-db) - (let* ((confirm-message "Loading elisp file from untrusted source may results in severe security problems. Load %S?") - (load-file-confirmed (or force-load - (y-or-n-p (format confirm-message new-db))))) - (if load-file-confirmed - (progn - (setf annotate-file new-db) - (cl-loop for annotated-buffer in (annotate-buffers-annotate-mode) do - (with-current-buffer annotated-buffer - (with-silent-modifications - (annotate-mode -1) - (annotate-mode 1))))) - (when annotate-use-messages - (message "Load aborted by the user")))) - (signal 'annotate-db-file-not-found (list new-db)))))) - -;; end of switching database - -;;; merging database - -(defun annotate--merge-interval (a b) - "Merge two annotation interval A and B. - -The new interval is expanded so that includes A and B." - (let ((new-left-limit (min (annotate--interval-left-limit a) - (annotate--interval-left-limit b))) - (new-right-limit (max (annotate--interval-right-limit a) - (annotate--interval-right-limit b)))) - (annotate--make-interval new-left-limit - new-right-limit))) - -(defun annotate--db-annotations-overlaps-p (annotation-a annotation-b) - "Return non nil if ANNOTATION-A and ANNOTATION-B overlaps." - (let ((interval-a (annotate-annotation-interval annotation-a)) - (interval-b (annotate-annotation-interval annotation-b))) - (not (or (< (annotate--interval-right-limit interval-b) - (annotate--interval-left-limit interval-a)) - (> (annotate--interval-left-limit interval-b) - (annotate--interval-right-limit interval-a)))))) - -(defun annotate--db-merge-annotations (host guest) - "Merge annotation GUEST into annotation HOST. -Uses `annotate--merge-interval'." - (when (annotate--db-annotations-overlaps-p host guest) - (let* ((interval-host (annotate-annotation-interval host)) - (interval-guest (annotate-annotation-interval guest)) - (text-host (annotate-annotation-string host)) - (text-guest (annotate-annotation-string guest)) - (new-interval (annotate--merge-interval interval-host interval-guest)) - (new-annotation-text (concat text-host " " text-guest)) - (left (annotate--interval-left-limit new-interval)) - (right (1+ (annotate--interval-right-limit new-interval))) - (new-annotated-text (with-current-buffer (current-buffer) - (buffer-substring-no-properties left right)))) - (annotate-make-annotation left right new-annotation-text new-annotated-text)))) - -(defun annotate--db-remove-overlap-annotations (annotations &optional accum) - "Recursively merges overlapping annotations in ANNOTATIONS -using `annotate--db-merge-annotations'." - (if (= (length annotations) 1) - (push (cl-first annotations) accum) - (let* ((probe (cl-first annotations)) - (rest-annotations (cl-rest annotations)) - (position-overlap (cl-position-if (lambda (a) - (annotate--db-annotations-overlaps-p probe a)) - rest-annotations))) - (if position-overlap - (let* ((annotation-overlapping (elt rest-annotations position-overlap)) - (annotations-before-merged (cl-subseq rest-annotations 0 position-overlap)) - (annotations-after-merged (cl-subseq rest-annotations (1+ position-overlap))) - (merged-annotation (annotate--db-merge-annotations probe - annotation-overlapping))) - (annotate--db-remove-overlap-annotations (append annotations-before-merged - (list merged-annotation) - annotations-after-merged) - accum)) - (annotate--db-remove-overlap-annotations rest-annotations (push probe accum)))))) - -(defun annotate--db-merge-databases (db-1 db-2 &optional accum) - "Recursively merge database DB-1 and DB-2." - (cl-labels ((find-same-file-record (record annotations-db) - (let ((record-filename (annotate-filename-from-dump record))) - (cl-find-if (lambda (a) - (let ((scanned-record-filename (annotate-filename-from-dump a))) - (file-equal-p record-filename scanned-record-filename))) - annotations-db)))) - (if (null db-1) - (append accum db-2) - (let* ((first-record (cl-first db-1)) - (same-file-record (find-same-file-record first-record db-2))) - (if same-file-record - (let* ((filename (annotate-filename-from-dump first-record)) - (concatenated-annotations (append (annotate-annotations-from-dump first-record) - (annotate-annotations-from-dump same-file-record))) - (non-overlapped-annotations (annotate--db-remove-overlap-annotations concatenated-annotations)) - (concatenated-checksum (annotate-checksum-from-dump first-record)) - (concatenated-record (annotate-make-record filename - non-overlapped-annotations - concatenated-checksum)) - (rest-of-db-2 (cl-remove-if - (lambda (a) - (let ((record-filename (annotate-filename-from-dump a))) - (file-equal-p record-filename filename))) - db-2))) - (annotate--db-merge-databases (cl-rest db-1) - rest-of-db-2 - (push concatenated-record accum))) - (annotate--db-merge-databases (cl-rest db-1) - db-2 - (push first-record accum))))))) - -(defun annotate-import-annotations () - "Prompt user for an annotation database file and merge it into -their personal database." - (interactive) - (cl-flet ((deserialize-db (file) - (ignore-errors (annotate--deserialize-database-file file))) - (remove-non-existing-files (annotations) - (cl-remove-if-not (lambda (a) - (let ((filename (annotate-filename-from-dump a))) - (file-exists-p filename))) - annotations))) - (let* ((confirm-message (concat "Importing databases from untrusted source may cause severe " - "security issues, continue?")) - (import-confirmed-p (or (not annotate-database-confirm-import) - (y-or-n-p confirm-message)))) - (when import-confirmed-p - (let* ((imported-db-name (read-file-name "Choose the database to import: ")) - (imported-db (remove-non-existing-files (deserialize-db imported-db-name))) - (hosting-db (deserialize-db annotate-file)) - (merged-db (annotate--db-merge-databases hosting-db imported-db))) - (annotate-dump-annotation-data merged-db) - (annotate-switch-db t annotate-file) - (when annotate-use-messages - (message "Imported annotations from %s." imported-db-name))))))) - -;;; end of merging datatase - -(provide 'annotate) -;;; annotate.el ends here diff --git a/elpa/annotate-20251111.1635/README-elpa b/elpa/annotate-20251111.1635/README-elpa new file mode 100644 index 00000000..c02f9331 --- /dev/null +++ b/elpa/annotate-20251111.1635/README-elpa @@ -0,0 +1,15 @@ +This package provides the minor mode annotate-mode, which can add +annotations to arbitrary files without changing the files +themselves. Annotations are saved in the annotate-file +(~/.annotations by default). + +To add annotations to a file, select a region and hit C-c C-a. The +region will be underlined, and the annotation will be displayed in +the right margin. Annotations are saved whenever the file is saved. + +Use C-c ] to jump to the next annotation and C-c [ to jump to +the previous annotation. Use M-x annotate-export-annotations to +save annotations as a no-difference diff file. + +Important note for developers: annotation can not overlaps and newline character +can not be annotated. diff --git a/elpa/annotate-20251111.1635/annotate-autoloads.el b/elpa/annotate-20251111.1635/annotate-autoloads.el new file mode 100644 index 00000000..1a7051fa --- /dev/null +++ b/elpa/annotate-20251111.1635/annotate-autoloads.el @@ -0,0 +1,49 @@ +;;; annotate-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from annotate.el + +(let ((loads (get 'annotate 'custom-loads))) (if (member '"annotate" loads) nil (put 'annotate 'custom-loads (cons '"annotate" loads)) (put 'text 'custom-loads (cons 'annotate (get 'text 'custom-loads))))) +(autoload 'annotate-mode "annotate" +"Toggle Annotate mode. + +See https://github.com/bastibe/annotate.el/ for documentation. + +This is a minor mode. If called interactively, toggle the `Annotate +mode' mode. If the prefix argument is positive, enable the mode, and if +it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate the variable `annotate-mode'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(register-definition-prefixes "annotate" '("annotat" "on-window-size-change")) + +;;; End of scraped data + +(provide 'annotate-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; annotate-autoloads.el ends here diff --git a/elpa/annotate-20251111.1635/annotate-pkg.el b/elpa/annotate-20251111.1635/annotate-pkg.el new file mode 100644 index 00000000..92a22bb8 --- /dev/null +++ b/elpa/annotate-20251111.1635/annotate-pkg.el @@ -0,0 +1,9 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "annotate" "20251111.1635" + "Annotate files without changing them." + '((emacs "27.1")) + :url "https://github.com/bastibe/annotate.el" + :commit "9c80b465297dce20901abaf0389a48951b6e030f" + :revdesc "9c80b465297d" + :maintainers '(("Bastian Bechtold" . "bastibe.dev@mailbox.org") + ("cage" . "cage-dev@twistfold.it"))) diff --git a/elpa/annotate-20251111.1635/annotate.el b/elpa/annotate-20251111.1635/annotate.el new file mode 100644 index 00000000..e49eb253 --- /dev/null +++ b/elpa/annotate-20251111.1635/annotate.el @@ -0,0 +1,3792 @@ +;;; annotate.el --- annotate files without changing them -*- lexical-binding: t; -*- +;; Copyright © 2015 Bastian Bechtold and contributors: +;; Naoya Yamashita (2018) +;; Università degli Studi di Palermo (2019) + +;; Author: Bastian Bechtold +;; Maintainer: Bastian Bechtold , cage +;; URL: https://github.com/bastibe/annotate.el +;; Created: 2015-06-10 +;; Package-Version: 20251111.1635 +;; Package-Revision: 9c80b465297d +;; Package-Requires: ((emacs "27.1")) + +;; This file is NOT part of GNU Emacs. + +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: + +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +;;; Commentary: + +;; This package provides the minor mode annotate-mode, which can add +;; annotations to arbitrary files without changing the files +;; themselves. Annotations are saved in the annotate-file +;; (~/.annotations by default). +;; +;; To add annotations to a file, select a region and hit C-c C-a. The +;; region will be underlined, and the annotation will be displayed in +;; the right margin. Annotations are saved whenever the file is saved. +;; +;; Use C-c ] to jump to the next annotation and C-c [ to jump to +;; the previous annotation. Use M-x annotate-export-annotations to +;; save annotations as a no-difference diff file. + +;; Important note for developers: annotation can not overlaps and newline character +;; can not be annotated. + +;;; Code: + +(require 'info) + +(require 'cl-lib) + +;;;###autoload +(defgroup annotate nil + "Annotate files without changing them." + :version "2.4.5" + :group 'text) + +(defvar annotate-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-a") #'annotate-annotate) + (define-key map (kbd "C-c C-d") #'annotate-delete-annotation) + (define-key map (kbd "C-c C-p") #'annotate-change-annotation-text-position) + (define-key map (kbd "C-c C-c") #'annotate-change-annotation-colors) + (define-key map (kbd "C-c C-s") #'annotate-show-annotation-summary) + (define-key map (kbd "C-c ]") #'annotate-goto-next-annotation) + (define-key map (kbd "C-c [") #'annotate-goto-previous-annotation) + map)) + +;;;###autoload +(define-minor-mode annotate-mode + "Toggle Annotate mode. +See https://github.com/bastibe/annotate.el/ for documentation." + :lighter " Ann" + :group 'annotate + (annotate-initialize-maybe)) + +(defcustom annotate-file (locate-user-emacs-file "annotations" ".annotations") + "File where annotations are stored." + :type 'file) + +(defcustom annotate-file-buffer-local nil + "If non nil (default `nil'), for each annotated file \"filename\", a database +\"filename.notes\", containing the annotations, is generated in the +same directory that contains \"filename\"." + :type 'string) + +(defcustom annotate-buffer-local-database-extension "notes" + "The extension appended to the annotated filename to get the +name of the local database annotation" + :type 'string) + +(defcustom annotate-highlight-faces '((:underline "#EEF192") + (:underline "#92EEF1") + (:underline "#F192EE")) + "List of faces for annotated text." + :type '(repeat (plist))) + +(defcustom annotate-annotation-text-faces '((:background "#EEF192" :foreground "black") + (:background "#92EEF1" :foreground "black") + (:background "#F192EE" :foreground "black")) + "List of faces for annotation's text." + :type '(repeat (plist))) + +(defface annotate-prefix + '((t (:inherit default))) + "Face for character used to pad annotation. +This is the fill space between text lines and annotation text.") + +(defcustom annotate-annotation-column 85 + "Where annotations appear." + :type 'number) + +(defcustom annotate-diff-export-options "" + "Options passed to \"diff\" in `annotate-export-annotations'. +This is used when diffing between a buffer with and without +integrated annotations. +Note that there is an implicit \"-u\" at the end of default options +that Emacs passes to the diff program." + :type 'string) + +(defcustom annotate-use-messages t + "Whether status messages may appear in the minibuffer." + :type 'boolean) + +(defcustom annotate-popup-warning-indirect-buffer t + "Whether an information popup message is shown when killing an +annotated indirect buffer." + :type 'boolean) + +(defcustom annotate-integrate-marker " ANNOTATION: " + "Marker that is written before every integrated annotation." + :type 'string) + +(defcustom annotate-integrate-highlight ?~ + "Character used to underline an annotated text." + :type 'character) + +(defcustom annotate-fallback-comment "#" + "When variable `comment-start' is nil use this string instead." + :type 'string) + +(defcustom annotate-blacklist-major-mode '() + "Major modes in which to prevent auto-activation of command `annotate-mode'. +This is consulted when visiting a file. +It can be useful when some mode does not work well with +annotate (like source blocks in `org-mode') as this ensure that it +will be never loaded, see `annotate-initialize-maybe'." + :type '(repeat symbol)) + +(defcustom annotate-summary-ask-query t + "If non nil a prompt asking for a query to filter the database +before showing it in a summary window is used. If nil the +database is not filtered at all." + :type 'boolean) + +(defcustom annotate-database-confirm-deletion t + "If non nil a prompt asking confirmation before deleting a +database file that is going to be empty after saving an annotated +file will be shown." + :type 'boolean) + +(defcustom annotate-annotation-confirm-deletion nil + "If non nil a prompt asking confirmation before deleting an +annotation file will be shown." + :type 'boolean) + +(defcustom annotate-database-confirm-import t + "If non nil a prompt asking confirmation before importing a +database file will be shown." + :type 'boolean) + +(defcustom annotate-annotation-max-size-not-place-new-line 15 + "The maximum \"string-width\" allowed for an annotation to be +placed on the right margin of the window instead of its own line + after the annotated text." + :type 'number) + +(defconst annotate-allowed-positioning-policy + '(:by-length :margin :new-line) + "The allowed values for annotation positioning.") + +(defcustom annotate-annotation-position-policy :by-length + "Policy for annotation's position: +- :new-line + always in a new-line +- :margin + always on right margin +- :by-length + decide by text's length + +if the length is more than the value of +`annotate-annotation-max-size-not-place-new-line' place the +annotation on a new line, place on the right margin +otherwise." + :type 'symbol) + +(defcustom annotate-use-echo-area nil + "Whether annotation text should appear in the echo area only when mouse +id positioned over the annotated text instead of positioning them in +the the buffer (the default)." + :type 'boolean) + +(defcustom annotate-print-annotation-under-cursor nil + "Whether annotation text should appear in the minibuffer when +the cursor is positioned over an annotated text (default: nil). + +Important note: for this changes to take effect also +annotate-use-echo-area must be non nil" + :type 'boolean) + +(defcustom annotate-print-annotation-under-cursor-prefix "ANNOTATION: " + "Prefix that is printed before annotation in the minibuffer when +annotate-print-annotation-under-cursor is non nil" + :type 'string) + +(defcustom annotate-print-annotation-under-cursor-delay 0.5 + "The delay (in seconds) after an annotation id printed in the +minibuffer, when the pursor is placed over an annotated text. + +This variable works only if `annotate-print-annotation-under-cursor' is non nil" + :type 'float) + +(defcustom annotate-warn-if-hash-mismatch t + "Whether a warning message should be printed if a mismatch +occurs, for an annotated file, between the hash stored in the +database annotations and the hash calculated from the actual +file. + +This usually happens if an annotated file (a file with an entry in the +database) is saved with annotated-mode *not* active or the file +has been modified outside Emacs." + :type 'boolean) + +(defcustom annotate-endline-annotate-whole-line t + "Whether trying to annotate the end of line character will +annotate the whole line before (or after if the line is composed +by the newline character only) instead." + :type 'boolean) + +(defcustom annotate-search-region-lines-delta 2 + "When the annotated file is out of sync with its annotation +database the software looks for annotated text in the region with +delta equals to the value of this variable. Units are in number +of lines. The center of the region is the position of the +annotation as defined in the database." + :type 'number) + +(defcustom annotate-autosave t + "Whether annotations should be saved after each user action, +e.g. new annotation created, existing one amended or deleted." + :type 'boolean) + +(defcustom annotate-annotation-expansion-map '() + + "The expansion map for the annotation text. If a substring in the +annotation text matches the string in the first item of each element of +this list, it is expanded with the results of passing the second item — +as a command — to a system shell, if the third item is not null, the +output string of the command's results are trimmed (spaces or some +others non printable characters are removed from both ends, see: +`string-trim'). Example below. + +The expression: + +\(setf annotate-annotation-expansion-map + \\='((\"%d\" \"date +%Y-%m-%d\" t))) + +Will expand any occurrence of \"%d\" in the annotation's text with the +current date (format: \"YYYY-MM-DD\"), moreover the results will be +trimmed" + :type '(repeat (list string string boolean))) + +(defconst annotate-prop-chain-position + 'position) + +(defconst annotate-prop-chain-pos-marker-first + 0) + +(defconst annotate-prop-chain-pos-marker-last + -1) + +(defconst annotate-warn-file-changed-control-string + (concat "The file '%s' has changed on disk " + "from the last time the annotations were saved.\n" + "Chances are that they will not be displayed correctly.") + "The message to warn the user that file has been modified and +annotations positions could be outdated.") + +(defconst annotate-warn-file-searching-annotation-failed-control-string + (concat "The file '%s' has changed on disk " + "from the last time the annotations were saved and " + "Unfortunately was not possible to show annotation %S " + "because i failed looking for test %S.") + "The message to warn the user that file has been modified and +an annotations could not be restored.") + +(defconst annotate-warn-buffer-has-no-valid-file + "Annotations can not be saved: unable to find a file for buffer %S" + "The message to warn the user that a buffer it is not visiting +a valid file to be annotated.") + +(defconst annotate-popup-warn-killing-an-indirect-buffer + (concat "You killed an indirect buffer that contains annotation.\n" + "Annotate mode can not save annotation in an indirect buffer.\n" + "The buffer's content has been saved in a regular buffer " + "(together with its annotations) named:\n\n%S\n\n" + "If you want you can save that buffer in a file and " + "the annotations will be saved as well.") + "The message to warn the user that an annotated indirect buffer +has been killed.") + +(defconst annotate-error-summary-win-filename-invalid + "Error: File not found or in an unsupported format" + "The message to warn the user that file can not be show in +summary window because does not exist or is in an unsupported + format.") + +(defconst annotate-info-valid-file-extensions + '(".info" ".info.gz" ".gz") + "The valid extension for files that contains info document.") + +(defconst annotate-summary-list-prefix " " + "The string used as prefix for each text annotation item in summary window.") + +(defconst annotate-summary-list-prefix-file "* File: " + "The string used as prefix for each annotated file item in summary window.") + +(defconst annotate-summary-list-prefix-snippet "** Annotated text: " + "The string used as prefix for each annotation snippet item in summary window.") + +(defconst annotate-ellipse-text-marker "..." + "The string used when a string is truncated with an ellipse.") + +(defconst annotate-info-root-name "dir" + "The pseudo-filename of info root.") + +(defconst annotate-summary-buffer-name "*annotations*" + "The name of the buffer for summary window.") + +(defconst annotate-dump-from-indirect-bugger-suffix "-was-annotated-indirect-buffer" + "Append this suffix to a buffer generated from an annotated indirect buffer.") + +(defconst annotate-annotation-prompt "Annotation: " + "The prompt when asking user for annotation modification.") + +(defconst annotate-summary-delete-button-label "[delete]" + "The label for the button, in summary window, to delete an annotation.") + +(defconst annotate-summary-replace-button-label "[replace]" + "The label for the button, in summary window, to replace an annotation.") + +(defconst annotate-confirm-deleting-annotation-prompt "Delete this annotation? " + "Prompt to be shown when asking for annotation deletion confirm.") + +(defconst annotate-confirm-appending-newline-prompt "No newline character at the end of the buffer %S, annotation will not be displayed properly: append one? " + "Prompt to be shown when asking for appending a newline at the end of the buffer.") + +(defconst annotate-message-annotation-loaded "Annotations loaded." + "The message shown when annotations has been loaded.") + +(defconst annotate-message-annotations-not-found "No annotations found." + "The message shown when no annotations has been loaded from the database.") + +;;;; buffer locals variables + +(defvar-local annotate-echo-annotation-timer nil + "The buffer local variable bound to a timer that is in charge to print +the annotation under cursor on the echo area.") + +(defvar-local annotate-colors-index-counter 0 + "An always increasing value to address annotation colors +in the customizable colors lists: + +- annotate-highlight-faces +- annotate-annotation-text-faces.") + +;;;; custom errors + +(define-error 'annotate-error "Annotation error") + +(define-error 'annotate-empty-annotation-text-error + "Empty annotation text" + 'annotate-error) + +(define-error 'annotate-no-new-line-at-end-file-error + "No newline found at the end of the buffer" + 'annotate-error) + +(define-error 'annotate-db-file-not-found + "Annotations database file not found" + 'annotate-error) + +(define-error 'annotate-annotate-region-overlaps + "Error: the region overlaps with at least an already existing annotation" + 'annotate-error) + +(define-error 'annotate-query-parsing-error + "Parsing failed:" + 'annotate-error) + +(cl-defmacro annotate-with-disable-read-only (&body body) + "Run BODY with `read-only-mode' temporary disabled." + (let ((read-mode-p (gensym))) + `(let ((,read-mode-p (if buffer-read-only + 1 + -1))) + (when (= ,read-mode-p 1) + (read-only-mode -1)) + ,@body + (when (= ,read-mode-p 1) + (read-only-mode 1))))) + +(defun annotate-file-exists-p (filepath) + "Returns nil if the file pointed by `FILEPATH' does not exists +or an error occurs during the test +(e.g TRAMP mode fails to connect to remote server)." + (with-demoted-errors "Error: %S" + (file-exists-p filepath))) + +(defun annotate-annotations-exist-p () + "Does this buffer contains at least one or more annotations?" + (cl-find-if 'annotationp + (overlays-in 0 (buffer-size)))) + +(defun annotate-initialize-maybe () + "Initialize annotate mode only if buffer's major mode is not in the blacklist. +See `annotate-blacklist-major-mode'." + (cl-flet ((shutdown () + (setq annotate-mode t) + (annotate-shutdown) + (setq annotate-mode nil))) + (let ((annotate-allowed-p (with-current-buffer (current-buffer) + (not (apply #'derived-mode-p annotate-blacklist-major-mode))))) + (cond + ((not annotate-allowed-p) + (shutdown)) + (annotate-mode + (when (not (annotate-annotations-exist-p)) + (annotate-initialize))) + (t + (shutdown)))))) + +(cl-defun annotate-buffer-checksum (&optional (object (current-buffer))) + "Calculate an hash for the argument OBJECT." + (secure-hash 'md5 object)) + +(defun annotate-end-of-line-pos () + "Get the position of the end of line and rewind the point's +position (so that it is unchanged after this function is called)." + (line-end-position)) + +(defun annotate-beginning-of-line-pos () + "Get the position of the beginning of line and rewind the point's +position (so that it is unchanged after this function is called)." + (save-excursion + (beginning-of-line) + (point))) + +(defun annotate-annotated-text-empty-p (annotation) + "Does this ANNOTATION contains annotated text?" + (= (overlay-start annotation) + (overlay-end annotation))) + +(defun annotate-annotation-set-face (annotation face) + "Set property face to FACE for ANNOTATION." + (overlay-put annotation 'face face)) + +(defun annotate-annotation-face (annotation) + "Get property face from ANNOTATION." + (overlay-get annotation 'face)) + +(defun annotate-annotation-set-annotation-face (annotation face) + "Set property annotation-face to FACE for ANNOTATION." + (overlay-put annotation 'annotation-face face)) + +(defun annotate-annotation-property-annotation-face (annotation) + "Get property annotation-face from ANNOTATION." + (overlay-get annotation 'annotation-face)) + +(defun annotate-annotation-set-annotation-text (annotation annotation-text) + "Set the annotation's content for ANNOTATION to ANNOTATION-TEXT." + (overlay-put annotation 'annotation annotation-text)) + +(defun annotate-annotation-get-annotation-text (annotation) + "Get the annotation's content for ANNOTATION." + (overlay-get annotation 'annotation)) + +(defun annotate-annotation-set-position (annotation position) + "Set the annotation's position policy for ANNOTATION +to the value bound to POSITION." + (overlay-put annotation 'annotate-position position)) + +(defun annotate-annotation-get-position (annotation) + "Get the annotation's position policy for ANNOTATION." + (overlay-get annotation 'annotate-position)) + +(defun annotate-overlay-maybe-set-position (overlay position) + "Set the annotation's position policy for OVERLAY to the value bound +to POSITION,but only if the value of the property `position' is not null." + (when position + (annotate-annotation-set-position overlay position))) + +(defun annotate-chain-last-ring (chain) + "Get the last ring of CHAIN." + (car (last chain))) + +(defun annotate--remap-chain-pos (annotations) + "Remap ANNOTATIONS as an annotation \"chain\". + +An annotation is a collection of one or more overlays that +contains the property `annotate-prop-chain-position'. + +The value of `annotate-prop-chain-position' in each chain is an +integer starting from: + +`annotate-prop-chain-pos-marker-first' and *always* ending with + +`annotate-prop-chain-pos-marker-last' + +This means that a value of said property for a chain that +contains only an element is equal to +`annotate-prop-chain-pos-marker-last'. + +This function ensure this constrains for the chain ANNOTATION +belong." + (cond + ((< (length annotations) + 1) + annotations) + ((= (length annotations) + 1) + (annotate-annotation-set-chain-last (cl-first annotations))) + (t + (let ((all-but-last (butlast annotations)) + (last-element (car (last annotations)))) + (cl-loop for annotation in all-but-last + for i from annotate-prop-chain-pos-marker-first + do + (annotate-annotation-chain-position annotation i)) + (when last-element + (annotate-annotation-set-chain-last last-element)))))) + +(defun annotate-before-change-fn (a _b) + "This function is added to \"before-change-functions\" hook and +it is called any time the buffer content is changed (so, for +example, text is added or deleted). In particular, it will +rearrange the overlays bounds when an annotated text is +modified (for example a newline is inserted)." + (with-silent-modifications + (save-excursion + (let* ((bol (annotate-beginning-of-line-pos)) + (eol (annotate-end-of-line-pos)) + (ov (cl-remove-if-not #'annotationp + (overlays-in bol eol)))) + (dolist (overlay ov) + (annotate--remove-annotation-property (overlay-start overlay) + (overlay-end overlay)) + ;; check if we are breaking the overlay + (when (<= (overlay-start overlay) + a + (overlay-end overlay)) + (let ((start-overlay (overlay-start overlay))) + ;; delete overlay if there is no more annotated text + (when (<= a start-overlay) + (let ((chain (cl-remove overlay (annotate-find-chain overlay)))) + (delete-overlay overlay) + (annotate--remap-chain-pos chain)))))))))) + +(defun annotate-info-select-fn () + "The function to be called when an info buffer is updated." + (annotate-clear-annotations) + (annotate-load-annotations) + (font-lock-flush)) + +(defun on-window-size-change (_frame) + "The function to call when window-size-change-functions is called, +note that the argument _FRAME is ignored" + (font-lock-flush)) + +(defun annotate--filepath->local-database-name (filepath) + "Generates the file path of the local database form FILEPATH." + (concat (file-name-nondirectory filepath) + "." + annotate-buffer-local-database-extension)) + +(defun annotate--maybe-database-set-buffer-local () + "Sets, if user asked to do so, the annotation database to a +local version (i.e. a different database for each annotated file" + (when annotate-file-buffer-local + (make-local-variable 'annotate-file) + (when-let* ((buffer-file-path (buffer-file-name)) + (parent-directory (file-name-directory buffer-file-path)) + (db-name (annotate--filepath->local-database-name buffer-file-path))) + (setq-local annotate-file db-name)))) + +(defun annotate-timer-print-annotation-function () + "Print annotation under point in the minibuffer. +Used by the timer set in `annotate--maybe-make-timer-print-annotation'. + +See also the customizable variables: `annotate-echo-annotation-timer' and +`annotate-print-annotation-under-cursor'." + (with-current-buffer (current-buffer) + (when annotate-mode + (when-let* ((annotation (annotate-annotation-at (point)))) + (message "%s%s" + annotate-print-annotation-under-cursor-prefix + (annotate-annotation-get-annotation-text annotation)))))) + +(defun annotate-print-annotation-under-cursor-p () + "Non nil if the user configured the package to print +annotation's text in the minibuffer." + (and annotate-use-echo-area + annotate-print-annotation-under-cursor)) + +(defun annotate--maybe-make-timer-print-annotation () + "Set the timer to print the annotation's text in the minibuffer. +Used when the mode is activated." + (when (annotate-print-annotation-under-cursor-p) + (setf annotate-echo-annotation-timer + (run-with-idle-timer annotate-print-annotation-under-cursor-delay + t + #'annotate-timer-print-annotation-function)))) + +(defun annotate--maybe-cancel-timer-print-annotation () + "Cancel the timer to print the annotations text in the minibuffer. +Used when the mode is deactivated." + (when (and (annotate-print-annotation-under-cursor-p) + annotate-echo-annotation-timer + (timerp annotate-echo-annotation-timer)) + (cancel-timer annotate-echo-annotation-timer))) + +(defun annotate-initialize () + "Load annotations and set up save and display hooks." + (annotate--maybe-database-set-buffer-local) + (annotate--maybe-make-timer-print-annotation) + (annotate-load-annotations) + (add-hook 'kill-buffer-hook #'annotate-save-annotations t t) + (add-hook 'kill-emacs-hook #'annotate-save-all-annotated-buffers t nil) + ;; This hook is needed to reorganize the layout of the annotation + ;; text when a window vertically resized + (add-hook 'window-size-change-functions #'on-window-size-change t t) + (add-hook 'before-change-functions #'annotate-before-change-fn t t) + (add-hook 'Info-selection-hook #'annotate-info-select-fn t t) + (if annotate-use-echo-area + (font-lock-add-keywords + nil + '((annotate--font-lock-matcher (2 (annotate--annotation-builder))))) + (font-lock-add-keywords + nil + '((annotate--font-lock-matcher (2 (annotate--annotation-builder)) + (1 (annotate--change-guard))))))) + +(defun annotate-shutdown () + "Clear annotations and remove save and display hooks." + (annotate-clear-annotations) + (annotate--maybe-cancel-timer-print-annotation) + (remove-hook 'kill-buffer-hook #'annotate-save-annotations t) + (remove-hook 'kill-emacs-hook #'annotate-save-all-annotated-buffers nil) + (remove-hook 'window-size-change-functions #'on-window-size-change t) + (remove-hook 'before-change-functions #'annotate-before-change-fn t) + (remove-hook 'Info-selection-hook #'annotate-info-select-fn t) + (if annotate-use-echo-area + (font-lock-remove-keywords + nil + '((annotate--font-lock-matcher (2 (annotate--annotation-builder))))) + (font-lock-remove-keywords + nil + '((annotate--font-lock-matcher (2 (annotate--annotation-builder)) + (1 (annotate--change-guard))))))) + +(defun annotate-overlay-filled-p (overlay) + "Does this OVERLAY contains an `annotation' property?" + (and overlay + (overlayp overlay) + (annotate-annotation-get-annotation-text overlay))) + +(defun annotationp (overlay) + "Is OVERLAY an annotation?" + (annotate-overlay-filled-p overlay)) + +(cl-defmacro annotate-ensure-annotation ((overlay) &body body) + "Runs BODY only if OVERLAY is an annotation (i.e. passes annotationp)." + `(and (annotationp ,overlay) + (progn ,@body))) + +(defun annotate--position-on-annotated-text-p (pos) + "Does POS (as buffer position) corresponds to a character +that belong to some annotated text?" + (let ((annotation (annotate-annotation-at pos))) + (if annotation + t + ;; there is a chance that a point do not belong to the text + ;; rendered as annotated but belong to a chain anyway example: + ;; + ;; legend: + ;; a = annotated text + ;; * = non annotated text + ;; # = annotation + ;; + ;; Create a multiline annotation using region. + ;; + ;; aaaa + ;; aaaa + ;; aaaa + ;; + ;; + ;; aaaa + ;; aaaa + ;; aaaa #### + ;; + ;; place the cursor here: + ;; + ;; aaaa + ;; aaaa + ;; ^ cursor + ;; aaaa #### + ;; + ;; type some text + ;; + ;; aaaa + ;; ***** + ;; aaaa #### + ;; + ;; the text (the asterisks) is not rendered as annotated but as + ;; annotations can not have gaps so we enforce this limitation + ;; and consider it still parts of a chain formed by the + ;; surrounding annotated text. + (let* ((previous-annotation (annotate-previous-annotation-ends pos)) + (next-annotation (annotate-next-annotation-starts pos)) + (previous-chain (annotate-chain-first previous-annotation)) + (next-chain (annotate-chain-first next-annotation))) + (if (and previous-chain + next-chain + (eq previous-chain + next-chain)) + t + nil))))) + +(defun annotate-delete-chains-in-region (from to) + "Deletes all the chains enclosed in the range specified by +positions FROM and TO." + (let* ((enclosed-chains (annotate-annotations-chain-in-range from to))) + (dolist (chain enclosed-chains) + (annotate--delete-annotation-chain (cl-first chain))))) + +(defun annotate-count-newline-in-region (from to) + "Counts the number of newlines character (?\n) in range +specified by FROM and TO." + (cl-count-if (lambda (a) (char-equal a ?\n)) + (buffer-substring-no-properties from to))) + +(defun annotate--expand-annotation-text (annotation-text) + "Expand substrings of ANNOTATION-TEXT, using rules defined in the variable in +`in annotate-annotation-expansion-map'." + (cl-flet ((regex (expansion-item) + (cl-first expansion-item)) + (trimp (expansion-item) + (cl-third expansion-item)) + (command (expansion-item) + (cl-second expansion-item))) + (cl-loop with results = annotation-text + for expansion in annotate-annotation-expansion-map + when (string-match-p (regex expansion) results) + do (let ((expansion-results (shell-command-to-string (command expansion)))) + (when (trimp expansion) + (setf expansion-results (string-trim expansion-results))) + (setf results + (replace-regexp-in-string (regex expansion) + expansion-results + results + t + t))) + finally (return results)))) + +(defun annotate-annotate (&optional color-index) + "Create, modify, or delete annotation. +if COLOR-INDEX is not null must be an index that adresses an element both in +- `annotate-highlight-faces' +and +- `annotate-annotation-text-faces'" + (interactive "P") + (when color-index + (setf color-index (min (max (1- color-index) 0) + (1- (length annotate-highlight-faces))))) + (cl-labels ((create-new-annotation () + ;; create a new annotation in the region returned by `annotate-bound' + (cl-destructuring-bind (start end) + (annotate-bounds) + (let* ((raw-text (read-from-minibuffer annotate-annotation-prompt)) + (annotation-text (annotate--expand-annotation-text raw-text))) + (condition-case nil + (annotate-create-annotation start end annotation-text nil color-index) + (annotate-no-new-line-at-end-file-error + (user-error "Missing newline at the end of the buffer")) + (annotate-empty-annotation-text-error + (user-error "Annotation text is empty")))))) + (cut-right (region-beg region-stop &optional delete-enclosed) + ;; This function will trim on the right one or more + ;; existing chains of overlays that compose an + ;; annotation (i.e. the overlays applied on the + ;; annotated text). After this function is called the + ;; text staring from `region-beg' and ending on + ;; `region-stop' will be cleared of all annotations if + ;; `delete-enclosed' is non null. + (let* ((last-of-chain-to-cut (annotate-chain-last-at region-beg)) + (first-of-chain-to-cut (annotate-chain-first-at region-beg)) + (chain-start (overlay-start first-of-chain-to-cut)) + (chain-end (overlay-end last-of-chain-to-cut)) + (newlines-count (annotate-count-newline-in-region region-beg + chain-end)) + (cut-count (- chain-end + region-beg + newlines-count))) + (cl-loop repeat cut-count do + (when (annotate-annotation-at chain-start) + (annotate--cut-right-annotation first-of-chain-to-cut t))) + (when delete-enclosed + (annotate-delete-chains-in-region chain-end region-stop)))) + (cut-left (region-stop delete-enclosed) + ;; This function will trim on the left one or more + ;; existing chains of overlays that compose an + ;; annotation (i.e. the overlays applied on the + ;; annotated text). After this function is called the + ;; text starting from the last char of the last chain + ;; element of the annotation and ending on + ;; `region-stop' will be cleared of all annotations if + ;; `delete-enclosed' is non null. + (let* ((last-of-chain-to-cut (annotate-chain-last-at region-stop)) + (first-of-chain-to-cut (annotate-chain-first-at region-stop)) + (chain-start (overlay-start first-of-chain-to-cut)) + (chain-end (overlay-end last-of-chain-to-cut)) + (newlines-count (annotate-count-newline-in-region chain-start + region-stop)) + (cut-count (- region-stop + chain-start + newlines-count))) + (cl-loop repeat cut-count do + (when (annotate-annotation-at (1- chain-end)) + (annotate--cut-left-annotation last-of-chain-to-cut))) + (when delete-enclosed + (annotate-delete-chains-in-region chain-end region-stop)))) + (annotate-overwrite-range (start end) + ;; annotate text starting from `start' and ending on + ;; `end', overwriting any other annotation existing in + ;; that range + (goto-char end) + (push-mark (point) t t) + (goto-char start) + (annotate-annotate)) + (annotate-line (eol) + ;; annotate a line that terminate at `eol' + ;; + ;; if the line contains no text before the newline + ;; annotate the next line with text, if any. + ;; + ;; if the line contains a single annotation that spans + ;; the whole line update the existing annotation + ;; + ;; if the line contains no annotation, or more than + ;; one annotation, annotate the whole line that + ;; terminate at `eol' + (let* ((bol (annotate-beginning-of-line-pos)) + (annotations-on-the-line (annotate-annotations-overlay-in-range bol + eol))) + (if (= (length annotations-on-the-line) + 1) + (let* ((annotation (cl-first annotations-on-the-line)) + (start-overlay (overlay-start annotation)) + (end-overlay (overlay-end annotation)) + (annotation-spans-whole-line-p (and (= start-overlay bol) + (= end-overlay eol)))) + (if annotation-spans-whole-line-p + (progn + (goto-char end-overlay) + (push-mark start-overlay t t) + (annotate-change-annotation (overlay-start annotation)) + (pop-mark)) + (annotate-overwrite-range bol eol))) + (annotate-overwrite-range bol eol))))) + (let ((annotation (annotate-annotation-at (point)))) + (cond + ((use-region-p) + (let* ((region-beg (region-beginning)) + (region-stop (region-end)) + (enclosed-chains (annotate-annotations-chain-in-range region-beg region-stop))) + (cond + ((and (annotate--position-on-annotated-text-p region-beg) + (annotate--position-on-annotated-text-p region-stop)) + ;; aaaaaaaaaaaaaaaaaa + ;; ^-----------^ + (let ((starting-chain-at-start (annotate-chain-first-at region-beg)) + (starting-chain-at-end (annotate-chain-first-at region-stop))) + (if (eq starting-chain-at-start + starting-chain-at-end) + (signal 'annotate-annotate-region-overlaps nil) + (cut-left region-stop nil) + (cut-right region-beg region-stop t) + (create-new-annotation)))) + ((annotate--position-on-annotated-text-p region-beg) + ;; aaaabbcc********** + ;; ^------------^ + (cut-right region-beg region-stop t) + (create-new-annotation)) + ((annotate--position-on-annotated-text-p region-stop) + ;; **********cccaaaa + ;; ^------------^ + (cut-left region-stop t) + (create-new-annotation)) + (enclosed-chains + ;; ****aaaaaaaaaaaaaaa**** + ;; ^------------------^ + (annotate-delete-chains-in-region region-beg region-stop) + (create-new-annotation)) + (t + (create-new-annotation))))) + (annotation + (annotate-change-annotation (point)) + (font-lock-flush)) + (t + (if (annotate--position-on-annotated-text-p (point)) + (signal 'annotate-annotate-region-overlaps nil) + (let ((char-maybe-newline (char-after))) + (when char-maybe-newline + (cond + ((not (char-equal char-maybe-newline ?\n)) + (create-new-annotation)) + ((null annotate-endline-annotate-whole-line) + (user-error "The end of line can not be annotated")) + (t ;; annotate the whole line before or after + (save-excursion + (let* ((bol (annotate-beginning-of-line-pos)) + (eol (point))) + (if (/= eol bol) ; text before the newline, annotate it + (annotate-line eol) + (progn ; no text before the new + ; line, annotate next line + ; with proper text + (forward-line 1) + (goto-char (annotate-end-of-line-pos)) + (annotate-annotate)))))))))))) + (when annotate-autosave + (annotate-save-annotations))))) + +(defun annotate-toggle-annotation-text () + "Hide annotation's text at current cursor's point, if such annotation exists." + (interactive) + (when-let* ((chain (annotate-chain-at (point))) + (last-ring (annotate-chain-last-ring chain))) + (if (annotate-tail-overlay-hide-text-p last-ring) + (annotate-chain-show-text chain) + (annotate-chain-hide-text chain)) + (font-lock-flush))) + +(defun annotate-toggle-all-annotations-text () + "Hide annotation's text in the whole buffer." + (interactive) + (let ((chains (annotate-annotations-chain-in-range 0 (buffer-size)))) + (dolist (chain chains) + (if (annotate-tail-overlay-hide-text-p (annotate-chain-last-ring chain)) + (annotate-chain-show-text chain) + (annotate-chain-hide-text chain)))) + (font-lock-flush)) + +(cl-defun annotate-goto-next-annotation (&key (startingp t)) + "Move point to the next annotation." + (interactive) + (let ((annotation (annotate-annotation-at (point)))) + (if startingp + (if annotation + (let* ((chain-last (annotate-chain-last annotation)) + (annotation-last-end (overlay-end chain-last)) + (look-ahead (annotate-next-annotation-starts annotation-last-end))) + (if look-ahead + (progn + (goto-char annotation-last-end) + (annotate-goto-next-annotation :startingp nil)) + (when annotate-use-messages + (message "This is the last annotation.")))) + (let ((next-annotation (annotate-next-annotation-starts (point)))) + (when next-annotation + (goto-char (overlay-start next-annotation))))) + (if annotation + (let ((chain-first (annotate-chain-first annotation))) + (goto-char (overlay-start chain-first))) + (annotate-goto-next-annotation :startingp t))))) + +(cl-defun annotate-goto-previous-annotation (&key (startingp t)) + "Move point to the previous annotation." + (interactive) + (let ((annotation (annotate-annotation-at (point)))) + (if startingp + (if annotation + (let* ((chain-first (annotate-chain-first annotation)) + (annotation-first-start (overlay-start chain-first)) + (look-behind (annotate-previous-annotation-ends annotation-first-start))) + (if look-behind + (progn + (goto-char (1- annotation-first-start)) + (annotate-goto-previous-annotation :startingp nil)) + (when annotate-use-messages + (message "This is the first annotation.")))) + (let ((previous-annotation (annotate-previous-annotation-ends (point)))) + (when previous-annotation + (goto-char (1- (overlay-end previous-annotation)))))) + (if annotation + (let ((chain-last (annotate-chain-last annotation))) + (goto-char (overlay-end chain-last))) + (annotate-goto-previous-annotation :startingp t))))) + +(defun annotate-change-annotation-text-position () + "Change the policy positioning for the annotation under point." + (interactive) + (when-let* ((annotation (annotate-annotation-at (point)))) + (let ((current-position (annotate-annotation-get-position annotation))) + (if (null current-position) + (annotate-annotation-set-position annotation + (cl-first annotate-allowed-positioning-policy)) + (when-let* ((current-position-index (cl-position current-position + annotate-allowed-positioning-policy)) + (next-position-index (mod (1+ current-position-index) + (length annotate-allowed-positioning-policy)))) + (annotate-annotation-set-position annotation + (elt annotate-allowed-positioning-policy + next-position-index))))) + (message "New position policy for this annotation is %s" + (annotate-annotation-get-position annotation)) + (font-lock-flush))) + +(defun annotate-change-annotation-colors () + "Change the colors for the annotation under point." + (interactive) + (cl-flet ((new-color-index (annotation) + (let ((current-annotation-face (annotate-annotation-property-annotation-face annotation))) + (if current-annotation-face + (let* ((current-color-index (cl-position-if (lambda (a) + (cl-equalp current-annotation-face + a)) + annotate-annotation-text-faces)) + (new-color-index (mod (1+ current-color-index) + (length annotate-annotation-text-faces)))) + new-color-index) + 0)))) + (when-let* ((annotation (annotate-annotation-at (point)))) + (let ((new-color-index (new-color-index annotation))) + (annotate-annotation-set-annotation-face annotation + (elt annotate-annotation-text-faces + new-color-index)) + (annotate-annotation-set-face annotation + (elt annotate-highlight-faces + new-color-index)) + (font-lock-flush))))) + +(defun annotate-actual-comment-start () + "String for comment start related to current buffer's major +mode." + (or comment-start + annotate-fallback-comment)) + +(defun annotate-actual-comment-end () + "String for comment ends, if any, related to current buffer's +major mode." + (or comment-end + "")) + +(defun annotate-comments-length () + "Total length of the comment markers (start and end) strings." + (+ (string-width (annotate-actual-comment-start)) + (string-width (annotate-actual-comment-end)))) + +(defun annotate-wrap-in-comment (&rest strings) + "Put comment markers at the start and (if it makes sense) +end of a string. See: annotate-actual-comment-start and +annotate-actual-comment-end." + (apply #'concat (append (list (annotate-actual-comment-start)) + strings + (list (annotate-actual-comment-end))))) + +(cl-defstruct annotate-overlay-lines + overlay + line + relative-start + relative-end) + +(cl-defun annotate--integrate-annotations (&key (use-annotation-marker t) + (as-new-buffer t) + (switch-to-new-buffer t)) + "Export all annotations, This function is not part of the public API." + (cl-labels ((build-input-text-line () + (save-excursion + (annotate--split-lines (buffer-substring-no-properties (point-min) + (point-max)))))) + + (let* ((filename (annotate-actual-file-name)) + (export-buffer (generate-new-buffer (concat filename ".annotated.diff"))) + (annotations-overlays (sort (annotate-all-annotations) + (lambda (a b) + (< (overlay-start a) + (overlay-start b))))) + (lines-count (count-lines (point-min) (point-max))) + (buffer-lines (build-input-text-line)) + (ov-line-pos (mapcar (lambda (ov) + (line-number-at-pos (overlay-start ov))) + annotations-overlays)) + (ov-start-pos-in-line (mapcar (lambda (ov) + (save-excursion + (goto-char (overlay-start ov)) + (let ((bol (annotate-beginning-of-line-pos))) + (- (overlay-start ov) bol)))) + annotations-overlays)) + (ov-end-pos-in-line (mapcar (lambda (ov) + (save-excursion + (goto-char (overlay-start ov)) + (let ((bol (annotate-beginning-of-line-pos))) + (- (overlay-end ov) bol)))) + annotations-overlays)) + (overlay-relative-pos (cl-mapcar (lambda (ov line start end) + (make-annotate-overlay-lines :overlay ov + :line line + :relative-start start + :relative-end end)) + annotations-overlays + ov-line-pos + ov-start-pos-in-line + ov-end-pos-in-line)) + (parent-buffer-mode major-mode) + (output-buffer (if as-new-buffer + export-buffer + (current-buffer)))) + (with-current-buffer output-buffer + (erase-buffer) + (when as-new-buffer + (funcall parent-buffer-mode)) + (cl-loop + for buffer-line in buffer-lines + for line-number from 1 do + (let ((overlays-in-line (cl-remove-if-not (lambda (a) + (= (annotate-overlay-lines-line a) + line-number)) + overlay-relative-pos))) + (when (or (/= (1- line-number) + lines-count) + (not (annotate-string-empty-p buffer-line))) + (insert buffer-line "\n") + (cl-loop for ov-line-pos in overlays-in-line do + (let* ((overlay (annotate-overlay-lines-overlay ov-line-pos)) + (relative-start (annotate-overlay-lines-relative-start ov-line-pos)) + (relative-end (annotate-overlay-lines-relative-end ov-line-pos)) + (padding (if (<= (1- relative-start) 0) + "" + (make-string (1- relative-start) ? ))) + (annotated-lines (annotate--split-lines + (annotate-annotation-get-annotation-text overlay))) + (ov-length (- relative-end relative-start)) + (underline (make-string ov-length + annotate-integrate-highlight))) + (insert (annotate-wrap-in-comment padding underline) "\n") + (when (annotate-chain-last-p overlay) + (when use-annotation-marker + (insert (annotate-wrap-in-comment annotate-integrate-marker) "\n")) + (cl-loop for line in annotated-lines do + (insert (annotate-wrap-in-comment line) "\n"))))))))) + (when (and as-new-buffer + switch-to-new-buffer) + (switch-to-buffer output-buffer)) + (when (not as-new-buffer) + (delete-region (point) (point-max))) + output-buffer))) + +(defun annotate-integrate-annotations () + "Write all annotations into the file as comments below the annotated line. +An example might look like this:" + (interactive) + (annotate--integrate-annotations :use-annotation-marker t + :as-new-buffer nil + :switch-to-new-buffer nil) + (annotate-clear-annotations)) + +(defun annotate-export-annotations () + "Export all annotations as a unified diff file. +An example might look like this: + +--- .../annotate.el/annotate.el 2015-06-19 15:13:36.718796738 +0200 ++++ .../annotate.el/annotate.el 2015-06-19 15:13:36.718796738 +0200 +@@ -73,5 +73,5 @@ + ;;;###autoload + (defface annotate-highlight +- \\='((t (:underline \"coral\")))) ++ \\='((t (:underline \"coral\")))) +# ~~~~~~~~~~~~~~~~~~ +# this doesn't work in cli + \"Face for annotation highlights.\") + +This diff does not contain any changes, but highlights the +annotation, and can be conveniently viewed in diff-mode." + (interactive) + (let ((buffer (annotate--integrate-annotations :switch-to-new-buffer nil))) + (diff-buffers (current-buffer) buffer annotate-diff-export-options))) + +(defun annotate--font-lock-matcher (limit) + "Finds the next annotation. Matches two areas: +- the area between the overlay and the annotation +- the newline that will display the annotation + +The first match will get `annotate--change-guard' as its +`insert-in-front-hook', to make sure that if a newline is inserted +between the overlay and the annotation, the \"display\" property of +the newline is properly disposed of. + +The second match will get `annotate--annotation-builder' as its +`display' property, which makes the newline look like an +annotation plus the newline." + (goto-char (next-overlay-change (point))) + (if (>= (point) limit) + nil ; no match found before limit + (progn + ;; go to the end of the longest annotation under point + (let ((overlays (sort (cl-remove-if (lambda (a) + (not (and (annotationp a) + (< (overlay-end a) + limit)))) + (overlays-at (point))) + (lambda (x y) + (> (overlay-end x) + (overlay-end y)))))) + (when overlays + (goto-char (overlay-end (car overlays))))) + ;; capture the area from the overlay to EOL (regexp match #1) + ;; for the modification guard and the newline itself (regexp + ;; match #2) for the annotation. + (re-search-forward "\\(.*\\(\n\\)\\)" limit t)))) + +(cl-defstruct annotate-group + words + start-word) + +(defun annotate-group-by-width (text maximum-width) + "Groups TEXT in a list formed by chunks of maximum size equal +to MAXIMUM-WIDTH." + (cl-labels ((next-word (words) + (or (cl-first words) + "")) + (join-until-width (words &optional (word nil)) + (cond + ((null words) + (make-annotate-group :words nil + :start-word word)) + (t + (let* ((next-word (next-word words)) + (new-word (if word + (concat word " " next-word) + next-word))) + (if (<= (string-width new-word) + maximum-width) + (join-until-width (cl-rest words) new-word) + (make-annotate-group :words words + :start-word (or word next-word))))))) + (split-position (text column-max-width) + (let ((character-width (length text)) + (column-width (string-width text))) + (if (= character-width column-width) + column-max-width + (let* ((res 0) + (so-far "")) + (cl-loop for i from 0 below column-max-width + until (>= (string-width so-far) + column-max-width) + do + (setf so-far (concat so-far (string (elt text i)))) + (setf res i)) + res)))) + (%group (words so-far) + (cond + ((null words) + so-far) + ((<= (string-width (cl-first words)) + maximum-width) + (let* ((potential-start (join-until-width words)) + (word (annotate-group-start-word potential-start)) + (nonjoined-words (annotate-group-words potential-start)) + (rest-words nonjoined-words) + (potential-start word)) + (%group rest-words + (append (list potential-start) + so-far)))) + (t + (let* ((word (cl-first words)) + (rest-words (cl-rest words)) + (split-position (split-position word maximum-width)) + (prefix (cl-subseq word 0 split-position)) + (next-word (if rest-words + (cl-first rest-words) + "")) + (raw-suffix (cl-subseq word split-position)) + (suffix (if rest-words + (concat raw-suffix " " next-word) + raw-suffix))) + (%group (append (list suffix) + (cl-rest rest-words)) + (append (list prefix) + so-far)))))) + (%split-words (text) + (save-match-data (split-string text "[[:space:]]" t)))) + (if (< maximum-width 1) + nil + (let* ((words (%split-words text)) + (grouped (reverse (%group words '())))) + grouped)))) + +(cl-defun annotate-safe-subseq (seq from to &optional (value-if-limits-invalid seq)) + "Return a substring of SEQ or VALUE-IF-LIMITS-INVALID +sequence if FROM or TO are invalids." + (cond + ((< to from) + value-if-limits-invalid) + ((or (< from 0) + (> from (length seq)) + (> to (length seq))) + value-if-limits-invalid) + (t + (cl-subseq seq from to)))) + +(defun annotate-lineate (text line-width) + "Breaks TEXT into lines to fit in the annotation space with width LINE-WIDTH." + (cl-labels ((pad (string max-width add-newline-p) + (if (null string) + "" + (let* ((size (string-width string)) + (rest-width (max (- max-width + size) + 0)) + (padding (make-string rest-width + ? ))) + (if add-newline-p + (concat string padding "\n") + (concat string padding))))) + (%subseq (seq from to) + (if (= (length seq) 1) + nil + (annotate-safe-subseq seq from to nil)))) + (let* ((current-window (get-buffer-window (current-buffer))) + (theoretical-line-width (- (window-body-width current-window) + annotate-annotation-column)) + (available-width (if (> theoretical-line-width 0) + theoretical-line-width + line-width)) + (lineated-list (annotate-group-by-width text available-width)) + (max-width (apply #'max + (mapcar #'string-width lineated-list))) + (all-but-last-lineated-list (%subseq lineated-list 0 (1- (length lineated-list)))) + (last-line (if all-but-last-lineated-list + (car (last lineated-list)) + (cl-first lineated-list))) + (lineated (cl-mapcar (lambda (a) + (pad a max-width t)) + all-but-last-lineated-list))) + (apply #'concat + (append lineated + (list (pad last-line max-width nil))))))) + +(cl-defun annotate--split-lines (text &optional (separator "\n")) + "Return TEXT splitted by SEPARATOR (default: \"\n\")." + (save-match-data + (split-string text separator))) + +(defun annotate--join-with-string (strings junction) + "Join list of string in STRINGS using string JUNCTION." + (cl-reduce (lambda (a b) (concat a junction b)) + strings)) + +(defun annotate-wrap-annotation-in-box (annotation-overlay + begin-of-line + end-of-line + annotation-on-is-own-line-p) + "Pads or breaks annotation text (as property of +ANNOTATION-OVERLAY so that all lines have the same width. + +If annotation is a placed on the margin of a window (that is +ANNOTATION-ON-IS-OWN-LINE-P is +nil) the text is broken (regardless of words) to fit on the side +of the window using BEGIN-OF-LINE END-OF-LINE. + +If annotation is a note that is placed in its own line the text is padded +with spaces so that a \"box\" surround the text without seams, e.g: + +aaa aaa +aa -> aa* +a a**" + (let ((annotation-text (annotate-annotation-get-annotation-text annotation-overlay))) + (cl-labels ((boxify-multiline (raw-annotation-text &optional add-space-at-end) + (let* ((lines (annotate--split-lines raw-annotation-text)) + (lines-widths (mapcar #'string-width lines)) + (max-width (cl-reduce (lambda (a b) (if (> a b) + a + b)) + lines-widths + :initial-value -1)) + (padding-sizes (mapcar (lambda (a) (- max-width + (string-width a))) + lines)) + (paddings (mapcar (lambda (a) (make-string a ? )) + padding-sizes)) + (box-lines (cl-mapcar (lambda (a b) (concat a b)) + lines paddings)) + (almost-boxed (annotate--join-with-string box-lines "\n"))) + (if add-space-at-end + (concat almost-boxed " ") + almost-boxed)))) + (if annotation-on-is-own-line-p + (list (boxify-multiline annotation-text t)) + (let* ((lineated (annotate-lineate annotation-text + (- end-of-line begin-of-line))) + (boxed (boxify-multiline lineated nil))) + (annotate--split-lines boxed)))))) + +(defun annotate--current-highlight-face () + "Reurns the current annotation color theme." + (elt annotate-highlight-faces + (mod annotate-colors-index-counter + (length annotate-highlight-faces)))) + +(defun annotate--current-annotation-text-face () + "Reurns the current annotation's text color theme." + (elt annotate-annotation-text-faces + (mod annotate-colors-index-counter + (length annotate-annotation-text-faces)))) + +(defun annotate--annotation-builder () + "Searches the line before point for annotations, and returns a +\"facespec\" with the annotation in its \"display\" property." + (save-excursion + ;; (let ((newline-position (point))) + (goto-char (1- (point))) ; we start at the start of the previous line + ;; find overlays in the preceding line + (let ((prefix-first (annotate-make-prefix)) ; white spaces + ; before first + ; line of + ; annotation + (prefix-rest (make-string annotate-annotation-column ? )) + (bol (progn (beginning-of-line) (point))) + (eol (progn (end-of-line) (point))) + (annotation-text "") + (overlays nil) + (overlays-counter 1) + (hidden-text nil)) + ;; include previous line if point is at bol: + (when (null (overlays-in bol eol)) + (setq bol (1- bol))) + (setq overlays + (sort (cl-remove-if-not #'annotationp + (overlays-in bol eol)) + (lambda (x y) + (< (overlay-end x) (overlay-end y))))) + ;; configure each annotation's properties and place it on the + ;; the window. The default position of the annotation (newline + ;; or right margin) is indicated by the value of the + ;; variable: `annotate-annotation-position-policy'. + (dolist (ov overlays) + (let* ((last-ring-p (annotate-chain-last-p ov)) + (annotation-face (annotate-annotation-face ov)) ; added by annotate-create-annotation + (annotation-text-face (annotate-annotation-property-annotation-face ov)) ; added by annotate-create-annotation + (position (annotate-annotation-get-position ov)) + (annotation-long-p (> (string-width (annotate-annotation-get-annotation-text ov)) + annotate-annotation-max-size-not-place-new-line)) + (new-position-policy position)) + (if (null position) + (setf new-position-policy + (if (eq annotate-annotation-position-policy + :by-length) + (if annotation-long-p + :new-line + :margin) + annotate-annotation-position-policy)) + (setf new-position-policy + (if (eq position + :by-length) + (if annotation-long-p + :new-line + :margin) + position))) + (let* ((wrap-in-a-new-line (eq new-position-policy :new-line)) + (multiline-annotation (annotate-wrap-annotation-in-box ov + bol + eol + wrap-in-a-new-line)) + (annotation-stopper (if (not (eq new-position-policy + :margin)) + (if (= overlays-counter + (length overlays)) + "\n" + "") + "\n")) + (tail-hidden-text-p (and last-ring-p + (annotate-tail-overlay-hide-text-p ov)))) + (setf hidden-text tail-hidden-text-p) + (cl-incf overlays-counter) + (annotate-annotation-set-face ov annotation-face) + (annotate-annotation-set-annotation-face ov annotation-text-face) + (when (and (not annotate-use-echo-area) + (not hidden-text) + (annotate-chain-last-p ov)) + (when (and new-position-policy + (not (eq new-position-policy :margin))) + (setf prefix-first " \n")) + (dolist (l multiline-annotation) + (setq annotation-text + (concat annotation-text + prefix-first + (propertize l 'face annotation-text-face) + annotation-stopper)) + ;; white space before for all but the first annotation line + (if (eq new-position-policy + :new-line) + (setq prefix-first (concat prefix-first prefix-rest)) + (setq prefix-first prefix-rest))))))) + (when (not annotate-use-echo-area) + ;; build facespec with the annotation text as display property + (if (string= annotation-text "") + ;; annotation has been removed: remove display prop + (list 'face 'default 'display nil) + ;; annotation has been changed/added: change/add display prop + (list 'face 'default 'display annotation-text)))))) + +(defun annotate--remove-annotation-property (_begin end) + "Cleans up annotation properties associated within a region +surrounded by _BEGIN and END." + (when (and annotate-mode + (> (buffer-size) 0)) + (with-silent-modifications + (annotate-with-disable-read-only + ;; copy undo list + (let ((saved-undo-list (copy-tree buffer-undo-list t))) + ;; inhibit property removal to the undo list (and empty it too) + (buffer-disable-undo) + (save-excursion + (goto-char end) + ;; go to the EOL where the + ;; annotated newline used to be + (end-of-line) + ;; strip dangling display property + (when (< (point) + (point-max)) + (remove-text-properties (point) (1+ (point)) '(display nil)))) + ;; restore undo list + (setf buffer-undo-list saved-undo-list) + (buffer-enable-undo)))))) + +(defun annotate-annotations-overlay-in-range (from-position to-position) + "Return the annotations overlays that are enclosed in the range +defined by FROM-POSITION and TO-POSITION." + (let ((annotations ()) + (counter (max 0 (1- from-position)))) + (catch 'scan-loop + (while (<= counter + to-position) + (cl-incf counter) + (let ((annotation (annotate-next-annotation-starts counter))) + (if (annotationp annotation) + (let ((chain-end (overlay-end (annotate-chain-last annotation))) + (chain-start (overlay-start (annotate-chain-first annotation)))) + (setf counter chain-end) + (when (and (>= chain-start from-position) + (<= chain-end to-position)) + (cl-pushnew annotation annotations))) + (throw 'scan-loop t))))) + (reverse annotations))) + +(defun annotate-annotations-chain-in-range (from-position to-position) + "Return the annotations (chains) that are enclosed in the range +defined by FROM-POSITION and TO-POSITION." + (let ((annotations (annotate-annotations-overlay-in-range from-position to-position)) + (chains ())) + (cl-loop for annotation in annotations do + (let ((chain (annotate-find-chain annotation))) + (cl-pushnew chain chains :test (lambda (a b) (eq (cl-first a) (cl-first b)))))) + (reverse chains))) + +(defun annotate--change-guard () + "Return a `facespec' with an `insert-behind-hooks' property +that strips dangling `display' properties of text insertions if +text is inserted. This cleans up after newline insertions between +an overlay and it's annotation." + (list 'face + nil + 'insert-in-front-hooks + '(annotate--remove-annotation-property))) + +(defun annotate-prefix-lines (prefix text &optional omit-trailing-null) + "Prepend PREFIX to each line in TEXT. +If OMIT-TRAILING-NULL is non null, empty line at the end of +text will be discarded." + (let ((lines (annotate--split-lines text "\n"))) + (when omit-trailing-null + (let ((last-not-empty (cl-position-if-not #'annotate-string-empty-p + lines + :from-end t))) + (setf lines (cl-subseq lines 0 (1+ last-not-empty))))) + (apply #'concat (mapcar (lambda (l) (concat prefix l "\n")) lines)))) + +;;; database related procedures + +(cl-defun annotate-indirect-buffer-p (&optional (buffer (current-buffer))) + "Returns non nil if BUFFER (default the current buffer) is an indirect buffer." + (buffer-base-buffer buffer)) + +(defun annotate-indirect-buffer-current-p () + "Returns non nil if the current buffer is an indirect buffer." + (annotate-indirect-buffer-p)) + +(cl-defun annotate-guess-filename-for-dump (filename + &optional (return-filename-if-not-found-p t)) + "Guess an acceptable file name suitable for metadata database from FILENAME." + (cond + ((annotate-string-empty-p filename) + nil) + ((annotate-file-exists-p filename) + filename) + (t + (let ((found (if return-filename-if-not-found-p + filename + nil))) + (cl-block surrounding + (dolist (extension annotate-info-valid-file-extensions) + (let ((filename-maybe (concat filename extension))) + (when (annotate-file-exists-p filename-maybe) + (setf found filename-maybe) + (cl-return-from surrounding found))))) + found)))) + +(defun annotate-info-actual-filename () + "The info filename that feed this buffer or nil if not this +buffer is not on info-mode" + (annotate-guess-filename-for-dump Info-current-file nil)) + +(defun annotate-actual-file-name () + "Get the actual file name of the current buffer." + (cond + ((annotate-indirect-buffer-current-p) + nil) + (t + (let ((visited-filename (when (buffer-file-name) + (abbreviate-file-name (buffer-file-name))))) + (substring-no-properties (or (annotate-info-actual-filename) + visited-filename + (buffer-file-name (buffer-base-buffer)) + "")))))) + +(defun annotate-make-annotation-dump-entry (filename file-annotations checksum) + "Make an annotation record: see `annotate-load-annotations'." + (list filename + file-annotations + checksum)) + +(defun annotate-make-record (filename file-annotations checksum) + "Make an annotation record: see `annotate-load-annotations'." + (annotate-make-annotation-dump-entry filename file-annotations checksum)) + +(defun annotate-color-index-from-dump (record) + "Get the checksum field from an annotation list loaded from a +file." + (and (> (length record) 3) + (nth 4 record))) + +(defun annotate-placement-policy-from-dump (record) + "Get the checksum field from an annotation list loaded from a +file." + (and (> (length record) 4) + (nth 5 record))) + +(defun annotate-checksum-from-dump (record) + "Get the checksum field from an annotation list loaded from a +file." + (and (> (length record) 2) + (nth 2 record))) + +(defun annotate-annotations-from-dump (record) + "Get the annotations field from an annotation list loaded from a +file." + (nth 1 record)) + +(defun annotate-filename-from-dump (record) + "Get the filename field from an annotation list loaded from a +file." + (cl-first record)) + +(defun annotate-beginning-of-annotation (annotation) + "Get the starting point of an annotation. The arg ANNOTATION must be a single +annotation field got from a file dump of all annotated buffers, +essentially what you get from: +\(annotate-annotations-from-dump (nth index (annotate-load-annotations))))." + (cl-first annotation)) + +(defun annotate-ending-of-annotation (annotation) + "Get the ending point of an annotation. The arg ANNOTATION must be a single +annotation field got from a file dump of all annotated buffers, +essentially what you get from: +\(annotate-annotations-from-dump (nth index (annotate-load-annotations))))." + (cl-second annotation)) + +(defun annotate--interval-left-limit (a) + "Given an annotation record A returns the left limit of the annotated text." + (cl-first a)) + +(defun annotate--interval-right-limit (a) + "Given an annotation record A returns the right limit of the annotated text." + (cl-second a)) + +(defun annotate--make-interval (left-limit right-limit) + "Make an interval from LEFT-LIMIT and RIGHT-LIMIT." + (list left-limit right-limit)) + +(defun annotate-annotation-interval (annotation) + "Return the limits where ANNOTATION is applied. +The limit is a list of two numbers (LEFT RIGHT) representing of the portion +of the buffer where this annotation is applied. +Note that this function returns the character interval +yyyyyyyy ggg + ^^^^^^^ ← Annotation interval in the database + (extends for one more than the last character) + |----| ← The interval that this function returns. + +In other terms the interval in the database is a closed interval while +the interval that this function return is closed on the left and open on +the right side." + (annotate--make-interval (annotate-beginning-of-annotation annotation) + (1- (annotate-ending-of-annotation annotation)))) + +(defun annotate-annotation-string (annotation) + "Get the text of an annotation. The arg ANNOTATION must be a single +annotation field got from a file dump of all annotated buffers, +essentially what you get from: +\(annotate-annotations-from-dump (nth index (annotate-load-annotations))))." + (nth 2 annotation)) + +(defun annotate-annotated-text (annotation) + "Get the annotated text of an annotation. The arg ANNOTATION must be a single +annotation field got from a file dump of all annotated buffers, +essentially what you get from: +\(annotate-annotations-from-dump (nth index (annotate-load-annotations))))." + (and (> (length annotation) 3) + (nth 3 annotation))) + +(defun annotate-save-all-annotated-buffers () + "Save the annotations for all buffer where `annotate-mode' is active." + (let ((all-annotated-buffers (annotate-buffers-annotate-mode))) + (cl-loop for annotated-buffer in all-annotated-buffers do + (with-current-buffer annotated-buffer + (annotate-save-annotations))))) + +(cl-defun annotate--dump-indirect-buffer (annotations &optional (indirect-buffer (current-buffer))) + "Clone an annotated indirect buffer into a new buffer. +ANNOTATIONS containd the annotations and INDIRECT-BUFFER +\(default the current buffer) is the buffer to be cloned." + (when annotations + (let* ((new-buffer-name (generate-new-buffer-name (concat (buffer-name indirect-buffer) + annotate-dump-from-indirect-bugger-suffix))) + (new-buffer (get-buffer-create new-buffer-name)) + (indirect-content (with-current-buffer (current-buffer) + (buffer-string)))) + (with-current-buffer new-buffer + (annotate-mode -1) + (insert indirect-content) + ;; when launching the command `(annotate-mode 1)' annotate + ;; mode refuses to add the hooks if annotations are already + ;; present in the buffer. + ;; So the right way here is: first activate the mode and then + ;; add the annotations + (annotate-mode 1) + (cl-loop for annotation in annotations do + (let ((annotation-start (annotate-beginning-of-annotation annotation)) + (annotation-end (annotate-ending-of-annotation annotation)) + (annotation-text (annotate-annotation-string annotation))) + (annotate-create-annotation annotation-start + annotation-end + annotation-text + nil))) + (pop-to-buffer new-buffer) + (let* ((info-message (message annotate-popup-warn-killing-an-indirect-buffer + (buffer-name new-buffer))) + (user-choice (when annotate-popup-warning-indirect-buffer + (x-popup-dialog t (list info-message + (cons "OK" :ok) + (cons "Never show again" :bury)))))) + (when (eq user-choice :bury) + (customize-save-variable 'annotate-popup-warning-indirect-buffer nil))))))) + +(defun annotate-save-annotations () + "Save all annotations to disk." + (interactive) + (let ((file-annotations (cl-remove-if (lambda (a) + (= (annotate-beginning-of-annotation a) + (annotate-ending-of-annotation a))) + (annotate-describe-annotations))) + (all-annotations (annotate-load-annotation-data t)) + (filename (annotate-guess-filename-for-dump (annotate-actual-file-name)))) + (cond + (filename + (if (assoc-string filename all-annotations) + (setcdr (assoc-string filename all-annotations) + (list file-annotations + (annotate-buffer-checksum))) + (setq all-annotations + (push (annotate-make-annotation-dump-entry filename + file-annotations + (annotate-buffer-checksum)) + all-annotations))) + ;; remove duplicate entries (a user reported seeing them) + (dolist (entry all-annotations) + (delete-dups entry)) + ;; skip files with no annotations + (annotate-dump-annotation-data (cl-remove-if (lambda (entry) + (null (annotate-annotations-from-dump entry))) + all-annotations)) + (when annotate-use-messages + (message "Annotations saved."))) + ((annotate-indirect-buffer-current-p) + (annotate--dump-indirect-buffer file-annotations)) + (file-annotations + (lwarn '(annotate-mode) + :warning + annotate-warn-buffer-has-no-valid-file + (current-buffer)))))) + +(defun annotate-load-annotation-old-format () + "Load all annotations from disk in old format." + (interactive) + (let ((annotations (cdr (assoc-string (annotate-actual-file-name) + (annotate-load-annotation-data t))))) + ;; remove empty annotations created by earlier bug: + (setq annotations (cl-remove-if (lambda (ann) (null (nth 2 ann))) + annotations)) + (when (and (null annotations) + annotate-use-messages) + (message annotate-message-annotations-not-found)) + (when (not (null annotations)) + (save-excursion + (dolist (annotation annotations) + (let ((start (annotate-beginning-of-annotation annotation)) + (end (annotate-ending-of-annotation annotation)) + (annotation-string (annotate-annotation-string annotation))) + (annotate-create-annotation start end annotation-string nil))))) + (font-lock-flush) + (when annotate-use-messages + (message annotate-message-annotation-loaded)))) + +(defun annotate-load-annotations () + "Load all annotations from disk and redraw the buffer to render the annotations. + +The format of the database is: + +\(RECORD-1 RECORD-2 ... RECORD-N) + +Each record is: + +\(FILENAME ANNOTATIONS CHECKSUM) + +where: + +FILENAME: a string identifying a file on the file-system, or the +string \"dir\" for top-level info file. + +CHECKSUM: a string used to fingerprint the annotate file above, +used to check if a file has been modified. + +annotations: + +\(ANNOTATION-1 ANNOTATION-2 ... ANNOTATION-N) or nil + +finally annotation is: + +\(START END ANNOTATION-STRING ANNOTATED-TEXT COLOR-INDEX) + +START: the buffer position where annotated text start +END: the buffer position where annotated text ends +ANNOTATION-STRING: the text of annotation +ANNOTATED-TEXT: the substring of buffer from START to END (as above) +COLOR-INDEX: the index position in `annotate-annotation-text-faces' and + `annotate-highlight-faces' to chode the annotation's visual +POSITIONING-POLICY: a keyword representing the stategy for the annotation's + text position; the allowed values are specified in: + `annotate-allowed-positioning-policy' + +example: + +\\='(\"/foo/bar\" ((0 9 \"note\" \"annotated\" 0 :margin)) hash-as-hex-string)." + (interactive) + (cl-labels ((old-format-p (annotation) + (not (stringp (cl-first (last annotation)))))) + (let* ((filename (annotate-actual-file-name)) + (all-annotations-data (annotate-load-annotation-data t)) + (annotation-dump (assoc-string filename all-annotations-data)) + (annotations (annotate-annotations-from-dump annotation-dump)) + (old-checksum (annotate-checksum-from-dump annotation-dump)) + (new-checksum (annotate-buffer-checksum))) + (if (old-format-p annotation-dump) + (annotate-load-annotation-old-format) + (when (and annotate-warn-if-hash-mismatch + (not (old-format-p annotation-dump)) + old-checksum + new-checksum + (not (string= old-checksum new-checksum))) + (lwarn '(annotate-mode) + :warning + annotate-warn-file-changed-control-string + filename)) + (cond + ((and (null annotations) + annotate-use-messages) + (message annotate-message-annotations-not-found)) + (annotations + (save-excursion + (dolist (annotation annotations) + (let* ((start (annotate-beginning-of-annotation annotation)) + (end (annotate-ending-of-annotation annotation)) + (annotation-string (annotate-annotation-string annotation)) + (annotated-text (annotate-annotated-text annotation)) + (dump-color-index (annotate-color-index-from-dump annotation)) + (color-index (if (and dump-color-index + (< dump-color-index + (length annotate-highlight-faces))) + dump-color-index + nil)) + (position (annotate-placement-policy-from-dump annotation))) + (annotate-create-annotation start + end + annotation-string + annotated-text + color-index + position)))))) + (font-lock-flush) + (when annotate-use-messages + (message annotate-message-annotation-loaded)))))) + +(defun annotate-db-clean-records (records-db) + "Remove records from arg RECORDS-DB that have empty annotation, example: + +\\='((\"/foo/bar.dat\" nil \"abababababababababababababab\") + (\"/foo/baz.dat\" ((0 9 \"note\" \"annotated\")) \"abababababababababababababab\")) + +will become: + +\\='((\"/foo/baz.dat\" ((0 9 \"note\" \"annotated\")) \"abababababababababababababab\")) + +i.e. the first record is removed." + (cl-remove-if (lambda (a) (null (annotate-annotations-from-dump a))) + records-db)) + +(defun annotate-db-purge () + "Update database *on disk* removing all the records with empty +annotation." + (interactive) + (let ((db (annotate-db-clean-records (annotate-load-annotation-data t)))) + (annotate-dump-annotation-data db))) + +(defun annotate--deserialize-database-file (file) + "Return a sexp from the annotation database contained in FILE." + (cl-flet ((deserialize-record (record) + "deserialize `RECORD' form its sexp form." + (let* ((filename (annotate-filename-from-dump record)) + (annotations (annotate-annotations-from-dump record)) + (file-checksum (annotate-checksum-from-dump record))) + (annotate-make-record filename + annotations + file-checksum)))) + (with-temp-buffer + (let* ((annotations-file file) + (attributes (file-attributes annotations-file))) + (cond + ((not (annotate-file-exists-p annotations-file)) + (signal 'annotate-db-file-not-found (list annotations-file))) + ((= (file-attribute-size attributes) + 0) + nil) + (t + (insert-file-contents annotations-file) + (mapcar #'deserialize-record (read (current-buffer))))))))) + +(defun annotate-load-annotation-data (&optional ignore-errors) + "Read and returns saved annotations." + (if ignore-errors + (ignore-errors (annotate--deserialize-database-file annotate-file)) + (annotate--deserialize-database-file annotate-file))) + +(defun annotate-dump-annotation-data (data &optional save-empty-db) + "Save DATA into annotation file." + (cond + ((or save-empty-db + data) + (with-temp-file annotate-file + (cl-flet ((%make-record (annotation) + (let ((full-filename (annotate-filename-from-dump annotation)) + (annotations (annotate-annotations-from-dump annotation)) + (file-checksum (annotate-checksum-from-dump annotation))) + (annotate-make-record (abbreviate-file-name full-filename) + annotations + file-checksum)))) + (let* ((print-length nil) + (actual-data (mapcar #'%make-record data))) + (prin1 actual-data (current-buffer)))))) + ((annotate-file-exists-p annotate-file) + (let* ((confirm-message "Delete annotations database file %S? ") + (delete-confirmed-p (or (not annotate-database-confirm-deletion) + (y-or-n-p (format confirm-message annotate-file))))) + (if delete-confirmed-p + (condition-case err + (delete-file annotate-file t) + (error (message "error removing annotation database: %S" + (error-message-string err)))) + (annotate-dump-annotation-data data t)))))) + +(cl-defmacro with-matching-annotation-fns ((filename + beginning + ending) + &body body) + "Anaphoric macro to build functions to find annotations." + `(let ((filename-match-p (lambda (record) + (string= (annotate-filename-from-dump record) + ,filename))) + (annotation-limits-match-p (lambda (a) + (and (= (annotate-beginning-of-annotation a) + ,beginning) + (= (annotate-ending-of-annotation a) + ,ending))))) + ,@body)) + +(defun annotate-db-remove-annotation (db-records + record-filename + annotation-beginning + annotation-ending) + "Remove from database DB-RECORDS the annotation identified by +the triplets RECORD-FILENAME, ANNOTATION-BEGINNING and + ANNOTATION-ENDING; if such annotation does exists." + (with-matching-annotation-fns + (record-filename + annotation-beginning + annotation-ending) + (let ((file-matched-record (cl-find-if filename-match-p db-records))) + (if file-matched-record + (let* ((rest-of-db (cl-remove-if filename-match-p db-records)) + (new-annotations (cl-remove-if annotation-limits-match-p + (annotate-annotations-from-dump file-matched-record))) + (checksum (annotate-checksum-from-dump file-matched-record)) + (new-record (annotate-make-record record-filename + new-annotations + checksum))) + (push new-record + rest-of-db)) + db-records)))) + +(defun annotate-db-replace-annotation (db-records + record-filename + annotation-beginning + annotation-ending + replacing-text) + "Replace the text of annotation from database DB-RECORDS +identified by the triplets RECORD-FILENAME, + ANNOTATION-BEGINNING and ANNOTATION-ENDING; if such + annotation does exists." + (with-matching-annotation-fns + (record-filename + annotation-beginning + annotation-ending) + (let ((file-matched-record (cl-find-if filename-match-p db-records))) + (if file-matched-record + (let ((old-annotation (cl-find-if annotation-limits-match-p + (annotate-annotations-from-dump file-matched-record)))) + (if old-annotation + (let* ((rest-of-db (cl-remove-if filename-match-p db-records)) + (rest-annotations (cl-remove-if annotation-limits-match-p + (annotate-annotations-from-dump file-matched-record))) + (checksum (annotate-checksum-from-dump file-matched-record)) + (new-annotation (annotate-make-annotation annotation-beginning + annotation-ending + replacing-text + (annotate-annotated-text old-annotation))) + (new-record (annotate-make-record record-filename + (append (list new-annotation) + rest-annotations) + checksum))) + (push new-record + rest-of-db)) + db-records)) + db-records)))) + +(defun annotate-db-annotations-starts-before-p (a b) + "Non nil if annotation A starts before B. + +In this context annotation means annotation loaded from local +database not the annotation shown in the buffer (therefore these +arguments are \"record\" as called in the other database-related +functions)." + (< (annotate-beginning-of-annotation a) + (annotate-beginning-of-annotation b))) + +;;;; database related procedures ends here + +(defun annotate-clear-annotations () + "Clear all current annotations." + (interactive) + (let ((overlays (overlays-in 0 (buffer-size)))) + ;; only remove annotations, not all overlays + (setq overlays (cl-remove-if + (lambda (ov) (not (annotationp ov))) + overlays)) + (dolist (ov overlays) + (annotate--remove-annotation-property (overlay-start ov) + (overlay-end ov)) + (delete-overlay ov)))) + +(defun annotate-string-empty-p (a) + "Is the arg A an empty string or null?" + (or (null a) + (string= "" a))) + +(defun annotate-annotation-prop-get (annotation property) + "Get property PROPERTY from annotation ANNOTATION. If +ANNOTATION does not pass `annotationp' returns nil." + (annotate-ensure-annotation (annotation) + (overlay-get annotation property))) + +(defun annotate-annotation-get-chain-position (annotation) + "Get property's value that define position of this annotation +in a chain of annotations" + (annotate-annotation-prop-get annotation annotate-prop-chain-position)) + +(defun annotate-annotation-chain-position (annotation pos) + "Set property's value that define position of this annotation +in a chain of annotations." + (overlay-put annotation annotate-prop-chain-position pos)) + +(defun annotate-chain-last-p (annotation) + "Non nil if ANNOTATION is the last element of a chain of annotations." + (let ((value (annotate-annotation-get-chain-position annotation))) + (and value + (cl-equalp value annotate-prop-chain-pos-marker-last)))) + +(defun annotate-chain-first-p (annotation) + "Non nil if ANNOTATION is the first element, or the only +of a chain of annotations." + (let* ((chain-pos (annotate-annotation-get-chain-position annotation)) + (annotation-start (overlay-start annotation)) + (previous-annotation (annotate-previous-annotation-ends annotation-start)) + (previous-chain-pos (annotate-annotation-get-chain-position previous-annotation))) + (or (= chain-pos + annotate-prop-chain-pos-marker-first) + (and (= chain-pos + annotate-prop-chain-pos-marker-last) + (or (null previous-annotation) + (= previous-chain-pos + annotate-prop-chain-pos-marker-last)))))) + +(defun annotate-chain-first (annotation) + "Find first element of the chain where ANNOTATION belongs." + (cond + ((null annotation) + nil) + ((annotate-chain-first-p annotation) + annotation) + (t + (let* ((annotation-start (overlay-start annotation)) + (previous-annotation (annotate-previous-annotation-ends annotation-start))) + (annotate-chain-first previous-annotation))))) + +(defun annotate-chain-last (annotation) + "Find last element of the chain where ANNOTATION belongs." + (cond + ((null annotation) + nil) + ((annotate-chain-last-p annotation) + annotation) + (t + (let* ((annotation-end (overlay-end annotation)) + (next-annotation (annotate-next-annotation-starts annotation-end))) + (annotate-chain-last next-annotation))))) + +(defun annotate-chain-first-at (pos) + "Find first element of the chain of annotation that overlap point POS." + (let ((annotation (annotate-annotation-at pos))) + (annotate-ensure-annotation (annotation) + (annotate-chain-first annotation)))) + +(defun annotate-chain-last-at (pos) + "Find last element of the chain of annotation that overlap point POS." + (let ((annotation (annotate-annotation-at pos))) + (annotate-ensure-annotation (annotation) + (annotate-chain-last annotation)))) + +(defun annotate-chain-at (pos) + "Find the chain of overlays where point POS belongs." + (let ((annotation (annotate-annotation-at pos))) + (annotate-ensure-annotation (annotation) + (annotate-find-chain annotation)))) + +(defun annotate-annotation-set-chain-first (annotation) + "Set property's value that define position of this annotation +in a chain of annotations as first." + (annotate-annotation-chain-position annotation annotate-prop-chain-pos-marker-first)) + +(defun annotate-annotation-set-chain-last (annotation) + "Set property's value that define position of this annotation +in a chain of annotations as last." + (annotate-annotation-chain-position annotation annotate-prop-chain-pos-marker-last)) + +(defun annotate-find-chain (annotation) + "Find all ANNOTATION that are parts of the chain where ANNOTATION belongs." + (annotate-ensure-annotation (annotation) + (cl-labels ((find-next-annotation (pos) + (annotate-annotation-at (next-overlay-change pos)))) + (let* ((chain-first (annotate-chain-first annotation)) + (results (list chain-first)) + (chain-last (annotate-chain-last annotation)) + (start-pos (overlay-end chain-first)) + (next-annotation (find-next-annotation start-pos))) + (if (eq chain-first + chain-last) + results + (while (not (eq next-annotation + chain-last)) + (if next-annotation + (progn + (cl-pushnew next-annotation results) + (setf start-pos (overlay-end next-annotation))) + (cl-incf start-pos)) + (setf next-annotation (find-next-annotation start-pos))) + (push chain-last results) + (reverse results)))))) + +(defun annotate-annotations-chain-at (pos) + "Find all annotation that are parts of the chain that overlaps at POS." + (annotate-find-chain (annotate-annotation-at pos))) + +(defun annotate-chain-hide-text (chain) + "Sets an overlay properties of the last ring of CHAIN so that +the annotation's text will not be rendered." + (let ((last-ring (annotate-chain-last-ring chain))) + (overlay-put last-ring 'hide-text t))) + +(defun annotate-chain-show-text (chain) + "Sets an overlay properties of the last ring of CHAIN so that +the annotation's text will be rendered." + (let ((last-ring (annotate-chain-last-ring chain))) + (overlay-put last-ring 'hide-text nil))) + +(defun annotate-chain-hide-text-p (chain) + "Non nil if the annotation's text contained in the last ring of CHAIN +must not be rendered." + (let ((last-ring (annotate-chain-last (cl-first chain)))) + (annotate-tail-overlay-hide-text-p last-ring))) + +(defun annotate-tail-overlay-hide-text-p (overlay) + "Get the property for hiding the annotation text from OVERLAY." + (overlay-get overlay 'hide-text)) + +(defun annotate-create-annotation (start end annotation-text annotated-text + &optional color-index position) + "Create a new annotation for selected region (from START to END. + +Here the argument ANNOTATION-TEXT is the string that appears +on the margin of the window and ANNOTATED-TEXT is the string +that is underlined. + +If this function is called from procedure +`annotate-load-annotations' the argument ANNOTATED-TEXT +should be not null. In this case we know that an annotation +existed in a text interval defined in the database +metadata (the database located in the file specified by the +variable `annotate-file') and should just be +restored. Sometimes the annotated text (see above) can not be +found in said interval because the annotated file's content +changed and `annotate-mode' could not track the +changes (e.g. save the file when `annotate-mode' was not +active/loaded) in this case the matching +text (\"annotated-text\") is searched in a region surrounding the +interval and, if found, the buffer is annotated right there. + +The searched interval can be customized setting the variable: +\"annotate-search-region-lines-delta\". + +COLOR-INDEX, if non-null (default nil), is used as index to address +elements both in ANNOTATE-COLOR-INDEX-FROM-DUMP +and ANNOTATE-COLOR-INDEX-FROM-DUMP to specify annotation appearance. + +Finally POSITION indicates the positioning policy for the annotation, +if null the value bound to ANNOTATE-ANNOTATION-POSITION-POLICY is +used." + (cl-labels ((face-annotation-shifting-point (position shifting-direction-function) + (when-let* ((annotation (funcall shifting-direction-function + position)) + (annotation-face (annotate-annotation-face annotation))) + (cl-find-if (lambda (a) (cl-equalp annotation-face a)) + annotate-highlight-faces))) + (face-annotation-before-point (position) + (face-annotation-shifting-point position + #'annotate-previous-annotation-ends)) + (face-annotation-after-point (position) + (face-annotation-shifting-point (max (point-min) + (1- position)) + #'annotate-next-annotation-starts)) + (available-face-index (&rest used-faces) + (cl-position-if-not (lambda (a) + (cl-member a used-faces :test #'cl-equalp)) + annotate-highlight-faces)) + (create-annotation (start end annotation-text) + (if (null color-index) + (when-let* ((new-face-index (available-face-index (face-annotation-before-point start) + (face-annotation-after-point end)))) + (setf annotate-colors-index-counter + new-face-index)) + (cl-incf annotate-colors-index-counter)) + (save-excursion + (let ((all-overlays ())) + (while (< start end) + (goto-char start) + (let ((char-maybe-newline (string (char-after)))) + (if (string= char-maybe-newline "\n") + (goto-char (1+ (point))) + (progn + (re-search-forward "\n" end :goto-end) + (when (<= (point) end) + (let* ((end-overlay (if (/= (point) end) + (1- (point)) + (point))) + (highlight (make-overlay start end-overlay)) + (highlight-face (if color-index + (elt annotate-highlight-faces + color-index) + (annotate--current-highlight-face))) + (annotation-face (if color-index + (elt annotate-annotation-text-faces + color-index) + (annotate--current-annotation-text-face)))) + (annotate-annotation-set-face highlight highlight-face) + (annotate-annotation-set-annotation-text highlight annotation-text) + (annotate-annotation-set-annotation-face highlight annotation-face) + (annotate-overlay-maybe-set-position highlight position) + (annotate-overlay-maybe-set-help-echo highlight + annotation-text) + (annotate-annotation-chain-position highlight + annotate-prop-chain-pos-marker-last) + (push highlight all-overlays)))))) + (setf start (point))) + (annotate--remap-chain-pos (reverse (mapcar #'maybe-force-newline-policy + all-overlays)))))) + (beginning-of-nth-line (start line-count) + (save-excursion + (goto-char start) + (forward-line line-count) + (beginning-of-line) + (point))) + (go-backward (start) + (beginning-of-nth-line + start + (- annotate-search-region-lines-delta))) + (go-forward (start) + (beginning-of-nth-line start + annotate-search-region-lines-delta)) + (guess-match-and-add (start end annotated-text max) + (cl-block surrounding + (while (< start max) + (let ((to-match (ignore-errors + (buffer-substring-no-properties start end)))) + (if (and to-match + (string= to-match annotated-text)) + (cl-return-from surrounding start)) + (progn + (setf start (1+ start) + end (1+ end))))) + nil)) + (maybe-force-newline-policy (annotation) + ;; force newline policy if height of any the face of the + ;; overlay is different from height of default face + (save-excursion + (goto-char (overlay-start annotation)) + (let* ((bol (annotate-beginning-of-line-pos)) + (eol (annotate-end-of-line-pos)) + (changed-face-pos (min bol (overlay-start annotation))) + (limit (max eol (overlay-end annotation))) + (all-faces (list (get-text-property changed-face-pos 'face))) + (default-face-height (face-attribute 'default :height)) + (all-faces-height ()) + (force-newline-p nil)) + (while (< changed-face-pos limit) + (setf changed-face-pos + (next-single-property-change changed-face-pos + 'face + (current-buffer) + limit)) + (push (get-text-property changed-face-pos 'face) + all-faces)) + (setf all-faces-height + (mapcar (lambda (face) + (cond + ((facep face) + (face-attribute face :height nil 'default)) + ((and (consp face) + (keywordp (cl-first face))) ; a plist + (cl-getf face :height + (face-attribute 'default :height))) + ((consp face) ; a list of named face, first wins + (face-attribute (cl-first face) :height nil 'default)) + (t + (face-attribute 'default :height)))) + (remq nil all-faces))) + (setf force-newline-p + (cl-find-if (lambda (a) (/= a default-face-height)) + all-faces-height)) + (when force-newline-p + (annotate-annotation-set-position annotation :new-line))) + annotation)) + (next-to-a-line-terminator-p () + (save-excursion + (goto-char end) + (re-search-forward "\n" nil t)))) + (cond + ((annotate-string-empty-p annotation-text) + (signal 'annotate-empty-annotation-text-error t)) + ((and (not (or annotate-use-echo-area + (next-to-a-line-terminator-p))) + (annotate--confirm-append-newline-at-the-end-of-buffer)) + (save-excursion + (goto-char (point-max)) + (insert "\n")) + (annotate-create-annotation start + end + annotation-text + annotated-text + color-index position)) + (t + (if (not (annotate-string-empty-p annotated-text)) + (let ((text-to-match (ignore-errors + (buffer-substring-no-properties start end)))) + (if (and text-to-match + (string= text-to-match annotated-text)) + (create-annotation start end annotation-text) + (let* ((starting-point-matching (go-backward start)) + (ending-point-match (go-forward start)) + (length-match (- end start)) + (new-match (guess-match-and-add starting-point-matching + (+ starting-point-matching + length-match) + annotated-text + ending-point-match))) + (and new-match + (create-annotation new-match + (+ new-match length-match) + annotation-text))) + (lwarn '(annotate-mode) ; if matches annotated text failed + :warning + annotate-warn-file-searching-annotation-failed-control-string + (annotate-actual-file-name) + annotation-text + text-to-match))) + (create-annotation start end annotation-text)) ; create new annotation + (when (use-region-p) + (deactivate-mark)) + (save-excursion + (goto-char end) + (font-lock-fontify-block 1)))))) + +(defun annotate-overlay-put-echo-help (overlay text) + "Set the property `help-echo' to TEXT in overlay OVERLAY." + (overlay-put overlay 'help-echo text)) + +(defun annotate-overlay-get-echo-help (overlay) + "Set the property `help-echo' from overlay OVERLAY." + (overlay-get overlay 'help-echo)) + +(defun annotate-overlay-maybe-set-help-echo (overlay annotation-text) + "Set the property `help-echo' to ANNOTATION-TEXT in overlay OVERLAY if +the annotations should be shown in a popup fashion. + +See the variable: `annotate-use-echo-area'." + (when annotate-use-echo-area + (annotate-overlay-put-echo-help overlay annotation-text))) + +(defun annotate--delete-annotation-chain (annotation) + "Delete ANNOTATION from a buffer and the chain it belongs to. + +This function is not part of the public API." + (annotate-ensure-annotation (annotation) + (save-excursion + (with-current-buffer (current-buffer) + (let* ((chain (annotate-find-chain annotation))) + ;; (filename (annotate-actual-file-name)) + (dolist (single-element chain) + (goto-char (overlay-end single-element)) + (move-end-of-line nil) + (annotate--remove-annotation-property (overlay-start single-element) + (overlay-end single-element)) + (delete-overlay single-element))))))) + +(defun annotate--delete-annotation-chain-ring (annotation-ring) + "Delete overlay of ANNOTATION-RING from a buffer. + +A ring is a single element of an annotation chain. + +This function is not part of the public API." + (annotate-ensure-annotation (annotation-ring) + (save-excursion + (goto-char (overlay-end annotation-ring)) + (move-end-of-line nil) + (annotate--remove-annotation-property (overlay-start annotation-ring) + (overlay-end annotation-ring)) + (delete-overlay annotation-ring)))) + +(defun annotate-delete-chain-element (annotation) + "Delete a ring (a ring is a single element of an ANNOTATION chain.) +from a chain where ANNOTATION belong." + (annotate-ensure-annotation (annotation) + (let* ((chain (annotate-find-chain annotation)) + (first-of-chain-p (annotate-chain-first-p annotation)) + (last-of-chain-p (annotate-chain-last-p annotation)) + (only-element-in-chain-p (= (length chain) 1))) + (annotate--delete-annotation-chain-ring annotation) + (when (not only-element-in-chain-p) + (cond + (first-of-chain-p + (let ((second-annotation (cl-second chain))) + (when (not (annotate-chain-last-p second-annotation)) + (annotate-annotation-set-chain-first second-annotation)))) + (last-of-chain-p + (let ((annotation-before (elt chain (- (length chain) 2)))) + (annotate-annotation-set-chain-last annotation-before)))))))) + +(defun annotate--cut-left-annotation (annotation) + "Trims ANNOTATION exactly one character from the start." + (annotate-ensure-annotation (annotation) + (let* ((chain (annotate-find-chain annotation)) + (first-annotation (annotate-chain-first annotation)) + (chain-start-pos (overlay-start first-annotation)) + (first-annotation-ending-pos (overlay-end first-annotation)) + (new-starting-pos (1+ chain-start-pos))) + (cond + ((>= new-starting-pos + first-annotation-ending-pos) ; delete chain element or entire annotation + (if (= (length chain) + 1) ; the chain is formed by just one element, delete entirely + (annotate--delete-annotation-chain first-annotation) + (annotate-delete-chain-element first-annotation))) ; delete just the first element of the chain + (t + (move-overlay first-annotation new-starting-pos first-annotation-ending-pos)))))) + +(defun annotate--cut-right-annotation (annotation &optional refontify-buffer) + "Trims ANNOTATION exactly one character from the end." + (annotate-ensure-annotation (annotation) + (let* ((chain (annotate-find-chain annotation)) + (last-annotation (annotate-chain-last annotation)) + (last-annotation-ending-pos (overlay-end last-annotation)) + (last-annotation-starting-pos (overlay-start last-annotation)) + (new-ending-pos (1- last-annotation-ending-pos))) + (cond + ((<= new-ending-pos + last-annotation-starting-pos) ; delete chain element or entire annotation + (if (= (length chain) 1) ; the chain is formed by just one element, delete entirely + (annotate--delete-annotation-chain last-annotation) + (progn ; delete just the last element of the chain + (annotate-delete-chain-element last-annotation) + (when refontify-buffer + (font-lock-flush))))) + (t + (move-overlay last-annotation last-annotation-starting-pos new-ending-pos)))))) + +(defun annotate--delete-annotation-chain-prevent-modification (annotation) + "Delete an annotation chain backing up and restoring modification +status of the buffer before deletion occured. + +This function is not part of the public API." + (annotate-ensure-annotation (annotation) + (with-silent-modifications + (annotate--delete-annotation-chain annotation)))) + +(defun annotate--confirm-annotation-delete () + "Prompt user for delete confirmation. +This function is not part of the public API." + (or (not annotate-annotation-confirm-deletion) + (y-or-n-p annotate-confirm-deleting-annotation-prompt))) + +(cl-defun annotate-delete-annotation (&optional (point (point))) + "Command to delete an annotation, POINT is the buffer +position where to look for annotation (default the cursor +point)." + (interactive) + (when-let* ((annotation (annotate-annotation-at point))) + (let* ((delete-confirmed-p (annotate--confirm-annotation-delete))) + (when delete-confirmed-p + (annotate--delete-annotation-chain annotation) + (font-lock-flush))) + (when annotate-autosave + (annotate-save-annotations)))) + +(defun annotate--confirm-append-newline-at-the-end-of-buffer () + "Prompt user for appending newline confirmation. +This function is not part of the public API." + (y-or-n-p (format annotate-confirm-appending-newline-prompt (buffer-name)))) + +(defun annotate-change-annotation (pos) + "Change annotation at POS. If empty, delete annotation." + (let* ((highlight (annotate-annotation-at pos)) + (annotation-text (read-from-minibuffer annotate-annotation-prompt + (annotate-annotation-get-annotation-text highlight)))) + (cl-labels ((change (annotation) + (let ((chain (annotate-find-chain annotation))) + (dolist (single-element chain) + (annotate-overlay-maybe-set-help-echo single-element annotation-text) + (annotate-annotation-set-annotation-text single-element annotation-text))))) + (save-excursion + (cond + ;; annotation was cancelled: + ((null annotation-text)) + ;; annotation was erased: + ((string= "" annotation-text) + (let* ((delete-confirmed-p (annotate--confirm-annotation-delete))) + (when delete-confirmed-p + (annotate--delete-annotation-chain-prevent-modification highlight)))) + ;; annotation was changed: + (t + (change highlight))))))) + +(defun annotate-make-prefix () + "An empty string from the end of the line upto the annotation." + (save-excursion + (let* ((line-text (buffer-substring + (progn (beginning-of-line) (point)) + (progn (end-of-line) (point)))) + (prefix-length (- annotate-annotation-column (string-width line-text)))) + (if (< prefix-length 1) + (concat " \n" (make-string annotate-annotation-column ? )) + (make-string prefix-length ? ))))) + +(defun annotate-annotation-at (pos) + "Return the annotations (overlay where (annotationp overlay) -> t) +at positions POS or nil if no annotations exists at pos. + +NOTE this assumes that annotations never overlaps so the list of +all annotations can contains only one element maximum." + (let ((all (cl-remove-if-not #'annotationp + (overlays-at pos)))) + (cl-first all))) + +(defun annotate-previous-annotation-ends (pos) + "Return the previous annotation that ends before POS or nil if no annotation +was found. +NOTE this assumes that annotations never overlaps." + (cl-labels ((previous-annotation-ends (start) + (let ((annotation (annotate-annotation-at start))) + (while (and (> start + (point-min)) + (null annotation)) + (setf start (previous-overlay-change start)) + (setf annotation (annotate-annotation-at start))) + annotation))) + (let ((annotation (annotate-annotation-at pos))) + (if annotation + (previous-annotation-ends (1- (overlay-start annotation))) + (previous-annotation-ends pos))))) + +(defun annotate-previous-annotation (annotation) + "Return the annotation before ANNOTATIONS or nil if no such +annotation exists." + (annotate-previous-annotation-ends (overlay-start (annotate-chain-first annotation)))) + +(defun annotate-next-annotation-starts (pos) + "Return the next annotation that starts after POS or nil if no annotation +was found. +NOTE this assumes that annotations never overlaps." + (cl-labels ((next-annotation-ends (start) + (let ((annotation (annotate-annotation-at start))) + (while (and (/= start + (point-max)) + (null annotation)) + (setf start (next-overlay-change start)) + (setf annotation (annotate-annotation-at start))) + annotation))) + (let ((annotation (annotate-annotation-at pos))) + (if annotation + (next-annotation-ends (overlay-end annotation)) + (next-annotation-ends pos))))) + +(defun annotate-next-annotation (annotation) + "Return the annotation after ANNOTATIONS or nil if no such +annotation exists." + (annotate-next-annotation-starts (overlay-end (annotate-chain-last annotation)))) + +(defun annotate-symbol-strictly-at-point () + "Return non nil if a symbol is at char immediately following +the point. This is needed as `thing-at-point' family of + functions returns non nil if the thing (a symbol in this case) + is around the point, according to the documentation." + (cl-labels ((after-point () + (save-excursion + (goto-char (1+ (point))) + (bounds-of-thing-at-point 'symbol)))) + (let ((sym-on-point (bounds-of-thing-at-point 'symbol)) + (sym-after-point (after-point))) + (and sym-on-point + sym-after-point + (cl-equalp sym-on-point + sym-after-point))))) + +(defun annotate-bounds () + "The bounds of the region or whatever is at point." + (cl-labels ((left-ends () + (cond + ((use-region-p) + (region-beginning)) + ((annotate-symbol-strictly-at-point) + (let* ((annotation-before (annotate-previous-annotation-ends (point))) + (boundaries (bounds-of-thing-at-point 'symbol)) + (symbol-start (car boundaries)) + (annotation-end (if annotation-before + (overlay-end annotation-before) + -1))) + (max symbol-start + annotation-end))) + (t + (point)))) + (right-ends () + (cond + ((use-region-p) + (if (and (char-before (region-end)) + (char-equal (char-before (region-end)) + ?\n)) + (1- (region-end)) + (region-end))) + ((annotate-symbol-strictly-at-point) + (let* ((annotation-after (annotate-next-annotation-starts (point))) + (boundaries (bounds-of-thing-at-point 'symbol)) + (symbol-end (cdr boundaries)) + (annotation-start (if annotation-after + (overlay-start annotation-after) + (1+ symbol-end)))) + (min symbol-end + annotation-start))) + (t + (1+ (point)))))) + (list (left-ends) + (right-ends)))) + +(defun annotate-make-annotation (beginning ending annotation annotated-text) + "Make an annotation record that represent an annotation +starting at BEGINNING, terminate at ENDING with annotation +content ANNOTATION and annotated text ANNOTATED-TEXT." + (list beginning ending annotation annotated-text)) + +(defun annotate-all-annotations () + "Return a list of all annotations in the current buffer." + (cl-remove-if-not #'annotationp (overlays-in 0 (buffer-size)))) + +(defun annotate-describe-annotations () + "Return a list of all annotations in the current buffer. +The format is suitable for database dump." + (let ((all-annotations (cl-remove-if-not #'annotationp (overlays-in 0 (buffer-size)))) + (chain-visited ())) + (remq nil + (mapcar (lambda (annotation) + (let* ((chain (annotate-find-chain annotation)) + (chain-first (annotate-chain-first annotation)) + (chain-last (annotate-chain-last annotation)) + (from (overlay-start chain-first)) + (to (overlay-end chain-last)) + (face (annotate-annotation-face chain-first)) + (color-index (cl-position-if (lambda (a) (cl-equalp face a)) + annotate-highlight-faces)) + (position (annotate-annotation-get-position annotation))) + (when (not (cl-find-if (lambda (a) + (eq (cl-first chain) + (cl-first a))) + chain-visited)) + (push chain chain-visited) + (list from + to + (annotate-annotation-get-annotation-text annotation) + (buffer-substring-no-properties from to) + color-index + position)))) + all-annotations)))) + +(defun annotate-info-root-dir-p (filename) + "Is the name of this file (FILENAME) equals to the info root node?" + (string= filename + annotate-info-root-name)) + +(defun annotate-guess-file-format (filename) + "Try to guess the file format from FILENAME. +Non nil if the file format is supported from \"annotate\" in a more +sophisticated way than plain text." + (cl-labels ((file-contents () + (with-temp-buffer + (insert-file-contents filename) + (buffer-string))) + (info-format-p () ; lot of guesswork here :( + (cond + ((annotate-info-root-dir-p filename) + :info) + (t + (let* ((file-contents (file-contents)) + (has-info-p (string-match "info" filename)) + (separator-re "\^L?\^_\^L?\^J") + (has-separator-p (string-match separator-re file-contents)) + (has-node-p (string-match "Node:" file-contents))) + (if (and has-separator-p + (or has-node-p + has-info-p)) + :info + nil))))) + (gpg-format-p () + (with-temp-buffer + (let* ((magic-0 #x8c) + (magic-1 #x0d) + (magic-4 #x03) + (magic-5 #x02) + (attributes (file-attributes filename)) + (file-size (file-attribute-size attributes))) + (when (> file-size 6) + (let* ((bytes (insert-file-contents-literally filename + nil + 0 + 7))) + (setf bytes + (cl-loop for i from 1 to 6 collect + (elt (buffer-substring-no-properties i (1+ i)) + 0))) + (when (and (= (logand (elt bytes 0) #x0000ff) magic-0) + (= (logand (elt bytes 1) #x0000ff) magic-1) + (= (logand (elt bytes 4) #x0000ff) magic-4) + (= (logand (elt bytes 5) #x0000ff) magic-5)) + :encrypted-symmetric))))))) + (or (gpg-format-p) + (info-format-p)))) ;; keep this one for last as it is the slowest + +;;;; summary window procedures + +(define-button-type 'annotate-summary-show-annotation-button + 'follow-link t + 'help-echo "Click to show") + +(define-button-type 'annotate-summary-delete-annotation-button + 'follow-link t + 'help-echo "Click to remove annotation") + +(define-button-type 'annotate-summary-replace-annotation-button + 'follow-link t + 'help-echo "Click to replace annotation") + +(defun annotate-info-setup (file-or-node buffer) + "Display Info node FILE-OR-NODE in BUFFER. + +Compatibility wrapper for the function `info-setup' and `info-pop-to-buffer'." + (with-no-warnings + (if (version< "30" emacs-version) + (info-pop-to-buffer file-or-node buffer) + (info-setup file-or-node buffer)))) + +(defun annotate-summary-show-annotation-button-pressed (button) + "Callback called when an annotate-summary-show-annotation-button is activated." + (let* ((file (button-get button 'file)) + (file-type (annotate-guess-file-format file))) + (cond + ((eq file-type :info) + (with-current-buffer-window + "*info*" nil nil + (annotate-info-setup file (current-buffer)) + (switch-to-buffer "*info*")) + (with-current-buffer "*info*" + (goto-char (button-get button 'go-to)))) + (t + (let* ((buffer (find-file-other-window file))) + (with-current-buffer buffer + (goto-char (button-get button 'go-to)))))))) + +(defun annotate-update-visited-buffer-maybe (filename) + "Reload annotation mode in the buffer visiting FILENAME, if such buffer exists." + (let ((visited-buffer (find-buffer-visiting filename))) + (when visited-buffer ;; a buffer is visiting the file + (with-current-buffer visited-buffer + (annotate-mode -1) + (annotate-mode 1))))) + +(defun annotate-summary-delete-annotation-button-pressed (button) + "Callback for summary window fired when a \"delete\" button is +pressed." + (let* ((filename (button-get button 'file)) + (beginning (button-get button 'beginning)) + (ending (button-get button 'ending)) + (db (annotate-load-annotation-data t)) + (filtered (annotate-db-remove-annotation db filename beginning ending))) + (annotate-dump-annotation-data filtered) ; save the new database with entry removed + (cl-labels ((redraw-summary-window () ; update the summary window + (with-current-buffer annotate-summary-buffer-name + (read-only-mode -1) + (save-excursion + (button-put button 'invisible t) + (let ((annotation-button (previous-button (point)))) + (button-put annotation-button 'face '(:strike-through t))) + (let ((replace-button (next-button (point)))) + (button-put replace-button 'invisible t))) + (read-only-mode 1)))) + (redraw-summary-window) + (annotate-update-visited-buffer-maybe filename)))) + +(defun annotate-summary-replace-annotation-button-pressed (button) + "Callback for summary window fired when a \"replace\" button is +pressed." + (let* ((filename (button-get button 'file)) + (annotation-beginning (button-get button 'beginning)) + (annotation-ending (button-get button 'ending)) + (query (button-get button 'query)) + (db (annotate-load-annotation-data t)) + (old-annotation (button-get button 'text)) + (new-annotation-text (read-from-minibuffer annotate-annotation-prompt old-annotation))) + (when (not (annotate-string-empty-p new-annotation-text)) + (let ((replaced-annotation-db (annotate-db-replace-annotation db + filename + annotation-beginning + annotation-ending + new-annotation-text))) + (annotate-dump-annotation-data replaced-annotation-db) + (annotate-update-visited-buffer-maybe filename) + (annotate-show-annotation-summary query nil nil))))) + +(cl-defun annotate-wrap-text (text &optional (wrapper "\"")) + "Wrap string TEXT with string WRAPPER." + (concat wrapper text wrapper)) + +(cl-defun annotate-unwrap-text (text &optional (wrapper "\"") (left-side t)) + "Remove WRAPPER at both ends from TEXT." + (let ((results text) + (wrapper-length (length wrapper))) + (when (>= (length text) + wrapper-length) + (if left-side + (let ((maybe-wrapper (substring results 0 wrapper-length))) + (when (string= maybe-wrapper wrapper) + (setf results (substring results wrapper-length)) + (setf results (annotate-unwrap-text results wrapper nil)))) + (let ((maybe-wrapper (substring results + (- (length results) + wrapper-length)))) + (when (string= maybe-wrapper wrapper) + (setf results (substring results 0 (- (length results) + wrapper-length))))))) + results)) + +(cl-defun annotate-show-annotation-summary (&optional arg-query cut-above-point (save-annotations t)) + "Show a summary of all the annotations in a temp buffer, the +results can be filtered with a simple query language: see +`annotate-summary-filter-db'." + (interactive) + (cl-labels ((ellipsize (text prefix-string) + (let* ((prefix-length (string-width prefix-string)) + (ellipse-length (string-width annotate-ellipse-text-marker)) + (substring-limit (max 0 + (- (window-body-width) + prefix-length + ellipse-length + 2)))) ; this is for quotation marks + (if (> (string-width text) + substring-limit) + (concat (substring text 0 substring-limit) + annotate-ellipse-text-marker) + text))) + (wrap (text) + (annotate-wrap-text text "\"")) + (insert-item-summary (filename + snippet-text + button-text + annotation-beginning + annotation-ending + filter-query) + (insert annotate-summary-list-prefix-snippet) + (insert (wrap (ellipsize snippet-text + annotate-summary-list-prefix-snippet))) + (insert "\n") + (insert annotate-summary-list-prefix) + (insert-button (propertize (ellipsize button-text + annotate-summary-list-prefix) + 'face + 'bold) + 'file filename + 'go-to annotation-beginning + 'action 'annotate-summary-show-annotation-button-pressed + 'type 'annotate-summary-show-annotation-button) + (insert "\n\n") + (insert annotate-summary-list-prefix) + (insert " ") + (let ((del-button (insert-button + annotate-summary-delete-button-label + 'file filename + 'beginning annotation-beginning + 'ending annotation-ending + 'action + 'annotate-summary-delete-annotation-button-pressed + 'type + 'annotate-summary-delete-annotation-button))) + (button-put del-button + 'begin-of-button + (annotate-beginning-of-line-pos)) + (button-put del-button + 'end-of-button + (annotate-end-of-line-pos))) + (insert "\n") + (insert annotate-summary-list-prefix) + (insert " ") + (insert-button annotate-summary-replace-button-label + 'file filename + 'beginning annotation-beginning + 'ending annotation-ending + 'query filter-query + 'text button-text + 'action + 'annotate-summary-replace-annotation-button-pressed + 'type + 'annotate-summary-replace-annotation-button) + (insert "\n\n")) + (clean-snippet (snippet) + (save-match-data + (replace-regexp-in-string "[\r\n]" + " " + snippet))) + (build-snippet-info (filename annotation-begin annotation-end) + (with-temp-buffer + (annotate-info-setup filename (current-buffer)) + (buffer-substring-no-properties annotation-begin + annotation-end))) + (build-snippet-from-buffer (filename annotation-begin annotation-end) + (let ((visited-buffer (find-buffer-visiting filename))) + (when visited-buffer ;; a buffer is visiting the file + (with-current-buffer visited-buffer + (let ((raw-snippet (buffer-substring-no-properties annotation-begin + annotation-end))) + (clean-snippet raw-snippet)))))) + (build-snippet-from-file (filename annotation-begin annotation-end) + (with-temp-buffer + (insert-file-contents filename + nil + (1- annotation-begin) + (1- annotation-end)) + (clean-snippet (buffer-string)))) + (build-snippet (filename annotation-begin annotation-end) + (if (annotate-file-exists-p filename) + (cond + ((eq (annotate-guess-file-format filename) + :info) + (clean-snippet (build-snippet-info filename + annotation-begin + annotation-end))) + (t + (or (build-snippet-from-buffer filename + annotation-begin + annotation-end) + (build-snippet-from-file filename + annotation-begin + annotation-end)))) + (if (annotate-info-root-dir-p filename) + (clean-snippet (build-snippet-info filename + annotation-begin + annotation-end)) + annotate-error-summary-win-filename-invalid))) + (db-empty-p (dump) + (cl-every (lambda (a) + (cl-every #'null + (annotate-annotations-from-dump a))) + dump)) + (get-query () + (cond + (arg-query + arg-query) + (annotate-summary-ask-query + (read-from-minibuffer "Query: ")) + (t + ".*")))) + (when save-annotations + (annotate-save-all-annotated-buffers)) + (let* ((filter-query (get-query)) + (dump (annotate-summary-filter-db (annotate-load-annotation-data t) + filter-query + cut-above-point))) + (if (db-empty-p dump) + (when annotate-use-messages + (message "The annotation database is empty")) + (with-current-buffer-window + annotate-summary-buffer-name nil nil + (display-buffer annotate-summary-buffer-name) + (select-window (get-buffer-window annotate-summary-buffer-name t)) + (outline-mode) + (use-local-map nil) + (local-set-key "q" (lambda () + (interactive) + (kill-buffer annotate-summary-buffer-name))) + (dolist (annotation dump) + (let* ((all-annotations (annotate-annotations-from-dump annotation)) + (db-filename (annotate-filename-from-dump annotation))) + (when (not (null all-annotations)) + (insert (format (concat annotate-summary-list-prefix-file "%s\n\n") + db-filename)) + (dolist (annotation-field all-annotations) + (let* ((button-text (format "%s" + (annotate-annotation-string annotation-field))) + (annotation-begin (annotate-beginning-of-annotation annotation-field)) + (annotation-end (annotate-ending-of-annotation annotation-field)) + (snippet-text (build-snippet db-filename + annotation-begin + annotation-end))) + (insert-item-summary db-filename + snippet-text + button-text + annotation-begin + annotation-end + filter-query)))))) + (read-only-mode 1)))))) + +;;;; end summary window procedures + +;;;; filtering summary window: parser, lexer, etc. + +(defvar annotate-summary-query nil + "Holds the query to filter annotations when +summary window is shown.") + +(defvar annotate-summary-query-current-token nil + "Holds the next token of the query in `annotate-summary-query'.") + +(defun annotate-summary-query-lexer-symbol (res) + "The symbol identifying the token (e.g. \\='and)." + (elt res 0)) + +(defun annotate-summary-query-lexer-string (res) + "The string associated with this token." + (elt res 1)) + +(defun annotate-summary-query-lexer-start (res) + "The starting point of the substring of +`annotate-summary-query' for this token." + (elt res 2)) + +(defun annotate-summary-query-lexer-end (res) + "The ending point of the substring of +`annotate-summary-query' for this token." + + (elt res 3)) + +(cl-defun annotate-summary-lexer (&optional (look-ahead-p nil)) + "The lexer for `annotate-summary-query'. + +This function, when called, will produce the next token from +`annotate-summary-query'; a token is a substring with a well +defined meaning according to our grammar. + +For example this string: + +p.* and (a or not b) + +will be broken into these tokens: + +\\='(re \"p.*\" 0 3) +\\='(and \"and\" 4 7) +\\='(open-par \"(\" 8 9) +\\='(re \"a\" 9 10) +\\='(or \"or\" 11 12) +\\='(not \"not\" 14 17) +\\='(re \"b\" 18 19) +\\='(close-par \"(\" 19 20) + +The format is a proper list where: +- first element + a symbol representing the type of the token + - \\='re = regular expression + - \\='and , \\='or , \\='not = logical operator + - \\='open-par, \\='close-par = open and closing parenthesis respectively +- second element + the value (the actual substring for this token) + +- third and fourth element (currently unused) + the substring limits for this token (as returned by + MATCH-BEGINNING and MATCH-END. + +Note that spaces are ignored and all the tokens except \"re\" must +not be prefixed with a backslash to match. So, for example not -> +will match the token type \\='not but \not will match the token \\='re; +this way we can \"protect\" a regexp that contains reserved +keyword (aka escaping). + +The special value :no-more-token is returned after the whole +input is processed. + +Calling this function with value of LOOK-AHEAD-P nil will consume the +token from `annotate-summary-query' (i.e. that string is modified). + +example: +\"a and b\" -> \"and b\", \\='(re \"a\" 0 1) + +when LOOK-AHEAD-P is not nil the token is recognized but not cut away +from `annotate-summary-query'. + +example: +\"a and b\" -> \"a and b\", \\='(re \"a\" 0 1)" + (cl-labels ((build-token (token-symbol token-string token-beginning token-end) + (list token-symbol + token-string + token-beginning + token-end)) + (build-results (token-symbol register-num) + (build-token token-symbol + (match-string register-num annotate-summary-query) + (match-beginning register-num) + (match-end register-num))) + (cut-query (match-results) + (setf annotate-summary-query + (cl-subseq annotate-summary-query + (annotate-summary-query-lexer-end match-results))))) + (let ((re (concat "\\((\\)\\|\\()\\)\\|\\(and\\)\\|\\(not\\)\\|" + "\\(or\\)\\|\\(\".*\"\\)\\|\\([^[:space:]]+\\)"))) + (save-match-data + (let* ((matchedp (string-match re annotate-summary-query)) + (res (if matchedp + (cond + ((match-string 1 annotate-summary-query) + (build-results 'open-par 1)) + ((match-string 2 annotate-summary-query) + (build-results 'close-par 2)) + ((match-string 3 annotate-summary-query) + (build-results 'and 3)) + ((match-string 4 annotate-summary-query) + (build-results 'not 4)) + ((match-string 5 annotate-summary-query) + (build-results 'or 5)) + ((match-string 6 annotate-summary-query) + (build-results 'escaped-re 6)) + ((match-string 7 annotate-summary-query) + (build-results 're 7)) + (t + :no-more-tokens)) + :no-more-tokens))) + (when (and (listp res) + (not look-ahead-p)) + (cut-query res)) + res))))) + +(defun annotate-summary-query-parse-end-input-p (token) + "Non nil if there are no more tokens in `annotate-summary-query'." + (eq token :no-more-tokens)) + +(defun annotate-summary-token-symbol-match (looking-symbol token) + "Return non nil if LOOKING-SYMBOL is \"eq\" to the symbol +component of TOKEN." + (eq looking-symbol + (annotate-summary-query-lexer-symbol token))) + +(cl-defun annotate-summary-query-parse-note (filter-fn annotation &optional (res nil)) + "Parser rule for note: + +This function will parse the following production rules + +NOTE := \"(\" NOTE \")\" + | NOTE OPERATOR NOTE + | NOT NOTE + | RE + | ESCAPED-RE + | epsilon +OPERATOR := AND | OR +FILE-MASK := RE +RE := [^[:space:]] ; as regular expression +ESCAPED-RE := DELIMITER + ANYTHING + DELIMITER +ANYTHING := .* ; as a regular expression +AND := \"and\" +OR := \"or\" +NOT := \"not\" +DELIMITER := \" ; ASCII 34 (dec) 22 (hex) + +Arguments: + +- filter-fn is a function that accept two parameters: the regular + expression to match (a token of type \\='re, see the lexer + `annotate-summary-lexer' and a single annotation record (see + `annotate-load-annotations`). + + This function will reject (its value is nil) records that do + not match the annotation. + +- annotation + the annotation to test + +- res the results of this production rule (internal use only)." + (cl-labels ((token-symbol-match-p (looking-symbol token) + (annotate-summary-token-symbol-match looking-symbol token)) + ;; this function will parse the rule operator + ;; OPERATOR := AND | OR + ;; NOTE OPERATOR NOTE + ;; filter-fn see the docstring + ;; matchp non nil if (funcall filter-fn previous-token) is not nil + (operator (filter-fn annotation matchp) + (let ((look-ahead (annotate-summary-lexer t))) + (if (annotate-summary-query-parse-end-input-p look-ahead) + ;; end of input, recurse one more time + (annotate-summary-query-parse-note filter-fn + annotation + matchp) + (let ((look-ahead-symbol + (annotate-summary-query-lexer-symbol look-ahead)) + (look-ahead-string + (annotate-summary-query-lexer-string look-ahead))) + (cond + ((not (cl-find look-ahead-symbol '(and or close-par))) + (signal 'annotate-query-parsing-error + (list (format (concat "Expecting for operator " + "('and' or 'or') or \")\". " + "found %S instead") + look-ahead-string)))) + (t + ;; found operator, recurse to search for rhs of rule + ;; NOTE OPERATOR NOTE + (annotate-summary-query-parse-note filter-fn + annotation + matchp)))))))) + (let* ((look-ahead (annotate-summary-lexer t))) ; the next token that the lexer *will* consume + ; note the second arg is non nil + (if (not (annotate-summary-query-parse-end-input-p look-ahead)) + (progn + (cond + ((token-symbol-match-p 'close-par look-ahead) ; ignore closing parens + res) + ((token-symbol-match-p 'open-par look-ahead) ; next token is an open parens + ;; trying to match the rule: + ;; NOTE := '(' NOTE ')' + (annotate-summary-lexer) ; consume the token ')' + ;; match the note inside the parens + (let ((matchp (annotate-summary-query-parse-note filter-fn + annotation)) ; recurse + ;; after the note there *must* be a closing parenthesis + (maybe-close-parens (annotate-summary-lexer))) + ;; if not this is an error + (when (or (annotate-summary-query-parse-end-input-p maybe-close-parens) + (not (eq (annotate-summary-query-lexer-symbol maybe-close-parens) + 'close-par))) + (signal 'annotate-query-parsing-error '("Unmatched parens"))) + ;; continue parsing + (annotate-summary-query-parse-note filter-fn annotation matchp))) ; recurse + ((token-symbol-match-p 'not look-ahead) + (annotate-summary-lexer) ; consume the token 'not' + ;; the note after the 'not' operator in rule + ;; NOTE := NOT NOTE + ;; the third argument is the value to return if + ;; there are no more token left in the input string + (let ((res (annotate-summary-query-parse-note filter-fn annotation :error))) ; recurse + ;; if there are no more tokens here this is an error + ;; because, according to the grammar, after a NOT a + ;; NOTE is non optional + (if (eq :error res) + (signal 'annotate-query-parsing-error '("No more input after 'not'")) + ;; if the last rule (saved in res) is not nil (and + ;; is not :error) return nil, return the last + ;; annotation otherwise remember that the user asked + ;; for an annotation that *not* matches a regex + (if (null res) + annotation + nil)))) + ;; trying to match the rule: + ;; NOTE := NOTE AND NOTE + ((token-symbol-match-p 'and look-ahead) + (annotate-summary-lexer) ; consume the 'and' token + (let ((lhs res) ; the left side of this rule lhs AND rhs + (rhs (annotate-summary-query-parse-note filter-fn annotation :error))) ; recurse + (if (eq :error rhs) ; see the 'not' operator above + (signal 'annotate-query-parsing-error '("No more input after 'and'")) + (and lhs rhs)))) ; both rules must match as this is a logic and + ;; trying to match the rule: + ;; NOTE := NOTE OR NOTE + ((token-symbol-match-p 'or look-ahead) + (annotate-summary-lexer) ; consume the 'or' + (let ((lhs res) ; the left side of this rule (lhs OR rhs) + (rhs (annotate-summary-query-parse-note filter-fn annotation :error))) ; recurse + (if (eq :error rhs) + (signal 'annotate-query-parsing-error '("No more input after 'or'")) + (or lhs rhs)))) ; either lhs or rhs match as this is a logic or + ((token-symbol-match-p 'escaped-re look-ahead) + ;; here we match the rule: + ;; NOTE := ESCAPED-RE + ;; ESCAPED-RE is a delimited string like "foo bar" + ;; we first unescape the protected token + ;; "\"foo bar\"" -> "foo bar" (yes, just remove the delimiters) + ;; then we apply the filter function (see the docstring) + (let* ((escaped (annotate-summary-query-lexer-string (annotate-summary-lexer))) + (unescaped (substring escaped 1 (1- (length escaped)))) ; remove delimiters + (matchp (funcall filter-fn unescaped annotation))) ; apply the filter function + ;; and finally continue the parsing saving the results + ;; of applying the filter-fn function + (operator filter-fn annotation matchp))) + (t + ;; here we match the rule: + ;; NOTE := RE + ;; RE := a regular expression + ;; first just get the RE token + (let* ((regex (annotate-summary-query-lexer-string (annotate-summary-lexer))) + ;; then apply the filter function (see the docstring) + (matchp (funcall filter-fn regex annotation))) + ;; and finally continue the parsing saving the results + ;; of applying the filter-fn function + (operator filter-fn annotation matchp))))) + ;; if we are here the lexer can not find any more tokens in the query + ;; just return the value of res + res)))) ; end of '(if (not (annotate-summary-query-parse-end-input-p look-ahead))' + +(defun annotate-summary-query-parse-expression () + "Parse rule for expression: + +I feel this is very likely wrong in many ways, i hope linguists +are going to forgive me :-) + +EXPRESSION := FILE-MASK + | FILE-MASK AND NOTE + | FILE-MASK OR NOTE + | epsilon +NOTE := \"(\" NOTE \")\" + | NOTE OPERATOR NOTE + | NOT NOTE + | RE + | ESCAPED-RE + | epsilon +OPERATOR := AND | OR +FILE-MASK := RE +RE := [^[:space:]] ; as a regular expression +ESCAPED-RE := DELIMITER + ANYTHING + DELIMITER +ANYTHING := .* ; as a regular expression +AND := \"and\" +OR := \"or\" +NOT := \"not\" +DELIMITER := \" ; ASCII 34 (dec) 22 (hex) + +Note: this function returns the annotation part of the record, see +`annotate-load-annotations'." + (lambda (annotation query file-filter-fn note-filter-fn) + (let ((annotate-summary-query query) ; save the query + (query-notes-only nil)) ; the query for just the notes + (let ((next-token (annotate-summary-lexer))) ; get potential file-mask + ;; if there are no more tokens just return all the records + ;; these match the empty string as in rule + ;; EXPRESSION := epsilon + (if (annotate-summary-query-parse-end-input-p next-token) + (annotate-annotations-from-dump annotation) + ;; otherwise test the record with the file-mask + (let* ((quoted-file-mask-p (annotate-summary-token-symbol-match 'escaped-re + next-token)) + (file-mask-raw (annotate-summary-query-lexer-string next-token)) + (file-mask (if quoted-file-mask-p + (annotate-unwrap-text file-mask-raw "\"") + file-mask-raw)) + (filtered-annotation (funcall file-filter-fn file-mask annotation)) + ;; get the operator as in rule + (operator-token (annotate-summary-lexer))) + ;; if there are no operator just return the filtered (by file-mask) + ;; as in rule + ;; EXPRESSION := FILE-MASK + (if (annotate-summary-query-parse-end-input-p operator-token) + (annotate-annotations-from-dump filtered-annotation) + ;; otherwise get the operator and continue to parse the rule + ;; EXPRESSION := FILE-MASK AND NOTE + ;; or + ;; EXPRESSION := FILE-MASK OR NOTE + (let ((operator (annotate-summary-query-lexer-symbol operator-token))) + (cond + ((eq operator 'or) ; operator is 'or + ;; try to parse with the rule + ;; EXPRESSION := FILE-MASK OR NOTE + ;; return only the list annotation filtered by + ;; file-mask the former is non nil + (if filtered-annotation + (annotate-annotations-from-dump filtered-annotation) + ;; the annotation filtered by file-mask is empty, try to + ;; match the NOTE rule + (let ((look-ahead (annotate-summary-lexer t))) + ;; no more input after operator this is wrong + ;; according to the rule we are trying to match: + ;; EXPRESSION := FILE-MASK OR NOTE + (if (annotate-summary-query-parse-end-input-p look-ahead) + (signal 'annotate-query-parsing-error '("No more input after 'or'")) + (progn + ;; copy the string for note parsing note + ;; that annotate-summary-query only contains + ;; the substring to match the NOTE rule + (setf query-notes-only (concat annotate-summary-query)) + ;; parse all the annotations, we get a list + ;; where non nil elements are the annotation + ;; that passes the note-filter-fn test + (mapcar (lambda (a) + (let ((annotate-summary-query (concat query-notes-only))) + (annotate-summary-query-parse-note note-filter-fn + a))) + (annotate-annotations-from-dump annotation))))))) + ((eq operator 'and) + ;; try to parse with the rule + ;; EXPRESSION := FILE-MASK OR NOTE + (let ((look-ahead (annotate-summary-lexer t))) + ;; no more input after operator, this is wrong + ;; according to the rule we are trying to match: + ;; EXPRESSION := FILE-MASK AND NOTE + (if (annotate-summary-query-parse-end-input-p look-ahead) + (signal 'annotate-query-parsing-error '("No more input after 'and'")) + (progn + ;; copy the string for note parsing note + ;; that annotate-summary-query only contains + ;; the substring to match the NOTE rule + (setf query-notes-only (concat annotate-summary-query)) + ;; parse the already filtered by file-mask annotations only + ;; we get a list where non nil elements are the annotation + ;; that passes the note-filter-fn test + (mapcar (lambda (a) + (let ((annotate-summary-query (concat query-notes-only))) + (annotate-summary-query-parse-note note-filter-fn + a))) + (annotate-annotations-from-dump filtered-annotation)))))) + (t + ;; there is something after the file-mask in the + ;; input but it is not an operator + (signal 'annotate-query-parsing-error + (list (format "Unknown operator: %s is not in '(and, or)" + (annotate-summary-query-lexer-string operator-token)))))))))))))) + +(defun annotate-summary-filter-db (annotations-dump query remove-annotations-cutoff-point) + "Filter an annotation database with a query. + +The argument QUERY is a string that respect a simple syntax: + +- [file-mask] [(and | or) [not] regex-note [(and | or) [not] regexp-note ...]] + +where + +- file-mask: is a regular expression that should match the filepath + the annotation refers to; +- and, or, not : you guess? Classics logical operators; +- regex-note: the text of annotation must match this regular expression. + +Examples: + +- lisp$ and TODO + matches the text \"TODO\" in all lisp files + +Parenthesis can be used for the expression related to the text of +annotation, like this: + +- lisp$ and (TODO or important) + the same as above but checks also for string \"important\" + +- /home/foo/ + matches all the annotation that refers to file in the directory + '/home/foo' + +- /home/foo/ and not minor + matches all the annotation that refers to file in the directory + '/home/foo' and that not contains the text \"minor\". + +- .* and \"not\" + the \" can be used to escape strings + +If you want to remove from summary the annotations that appears +before a position in buffer set \"remove-annotations-cutoff-point\" to said +position. + +The annotations in each record are sorted by starting point in ascending order." + (let* ((parser (annotate-summary-query-parse-expression)) + (filter-file (lambda (file-mask annotation-dump) + (let ((filename + (annotate-filename-from-dump annotation-dump))) + (and (string-match-p file-mask filename) + annotation-dump)))) + (filter-annotations (lambda (re annotation-dump-2) + (and (string-match-p re + (annotate-annotation-string annotation-dump-2)) + annotation-dump-2))) + (filter (lambda (single-annotation) + (let ((filtered-annotations (funcall parser + single-annotation + query + filter-file + filter-annotations))) + (setf filtered-annotations + (remq nil filtered-annotations)) + (when filtered-annotations + (let ((filename (annotate-filename-from-dump + single-annotation)) + (checksum (annotate-checksum-from-dump + single-annotation))) + (setf filtered-annotations + (sort filtered-annotations + #'annotate-db-annotations-starts-before-p)) + (when remove-annotations-cutoff-point + (setf filtered-annotations + (cl-remove-if (lambda (a) + (< (annotate-ending-of-annotation a) + remove-annotations-cutoff-point)) + filtered-annotations))) + (annotate-make-annotation-dump-entry filename + filtered-annotations + checksum)))))) + (filtered (remq nil (mapcar filter annotations-dump)))) + filtered)) + +;;;; end of filtering: parser, lexer, etc. + +;;;; misc commands + +(defun annotate-summary-of-file-from-current-pos () + "Shows a summary window that contains only the annotations in +the current buffer and that starts after the current cursor's +position." + (interactive) + (with-current-buffer (current-buffer) + (when buffer-file-name + (annotate-show-annotation-summary (annotate-wrap-text buffer-file-name "\"") + (point))))) + +;;; switching database + +(defun annotate-buffers-annotate-mode () + "Return a list of all the buffers that have +annotate minor mode active." + (let ((all-buffers (buffer-list))) + (cl-labels ((annotate-mode-p (buffer) + (with-current-buffer buffer + (and (boundp 'annotate-mode) ;FIXME: Redundant test? + annotate-mode)))) + (cl-remove-if-not #'annotate-mode-p all-buffers)))) + +(cl-defun annotate-switch-db (&optional (force-load nil) (database-file-path nil)) + "Ask the user for a new annotation database files, load it and +refresh all the annotations contained in each buffer where +annotate minor mode is active. + +if DATABASE-FILE-PATH is nil (the default) a prompt asking for +a file containing database is presented to the user, otherwise +the value of this argument is used. + +If FORCE-LOAD is non nil no prompt asking user for confirmation +about loading the new file is shown. + +Note: this function will attempt to load (compile and +eval/execute) the content of the file as it was elisp source +code, always use load files from trusted sources!" + (interactive) + (let ((new-db (or database-file-path + (read-file-name "Database file location: ")))) + (when (not (annotate-string-empty-p new-db)) + (if (annotate-file-exists-p new-db) + (let* ((confirm-message "Loading elisp file from untrusted source may results in severe security problems. Load %S?") + (load-file-confirmed (or force-load + (y-or-n-p (format confirm-message new-db))))) + (if load-file-confirmed + (progn + (setf annotate-file new-db) + (cl-loop for annotated-buffer in (annotate-buffers-annotate-mode) do + (with-current-buffer annotated-buffer + (with-silent-modifications + (annotate-mode -1) + (annotate-mode 1))))) + (when annotate-use-messages + (message "Load aborted by the user")))) + (signal 'annotate-db-file-not-found (list new-db)))))) + +;; end of switching database + +;;; merging database + +(defun annotate--merge-interval (a b) + "Merge two annotation interval A and B. + +The new interval is expanded so that includes A and B." + (let ((new-left-limit (min (annotate--interval-left-limit a) + (annotate--interval-left-limit b))) + (new-right-limit (max (annotate--interval-right-limit a) + (annotate--interval-right-limit b)))) + (annotate--make-interval new-left-limit + new-right-limit))) + +(defun annotate--db-annotations-overlaps-p (annotation-a annotation-b) + "Return non nil if ANNOTATION-A and ANNOTATION-B overlaps." + (let ((interval-a (annotate-annotation-interval annotation-a)) + (interval-b (annotate-annotation-interval annotation-b))) + (not (or (< (annotate--interval-right-limit interval-b) + (annotate--interval-left-limit interval-a)) + (> (annotate--interval-left-limit interval-b) + (annotate--interval-right-limit interval-a)))))) + +(defun annotate--db-merge-annotations (host guest) + "Merge annotation GUEST into annotation HOST. +Uses `annotate--merge-interval'." + (when (annotate--db-annotations-overlaps-p host guest) + (let* ((interval-host (annotate-annotation-interval host)) + (interval-guest (annotate-annotation-interval guest)) + (text-host (annotate-annotation-string host)) + (text-guest (annotate-annotation-string guest)) + (new-interval (annotate--merge-interval interval-host interval-guest)) + (new-annotation-text (concat text-host " " text-guest)) + (left (annotate--interval-left-limit new-interval)) + (right (1+ (annotate--interval-right-limit new-interval))) + (new-annotated-text (with-current-buffer (current-buffer) + (buffer-substring-no-properties left right)))) + (annotate-make-annotation left right new-annotation-text new-annotated-text)))) + +(defun annotate--db-remove-overlap-annotations (annotations &optional accum) + "Recursively merges overlapping annotations in ANNOTATIONS +using `annotate--db-merge-annotations'." + (if (= (length annotations) 1) + (push (cl-first annotations) accum) + (let* ((probe (cl-first annotations)) + (rest-annotations (cl-rest annotations)) + (position-overlap (cl-position-if (lambda (a) + (annotate--db-annotations-overlaps-p probe a)) + rest-annotations))) + (if position-overlap + (let* ((annotation-overlapping (elt rest-annotations position-overlap)) + (annotations-before-merged (cl-subseq rest-annotations 0 position-overlap)) + (annotations-after-merged (cl-subseq rest-annotations (1+ position-overlap))) + (merged-annotation (annotate--db-merge-annotations probe + annotation-overlapping))) + (annotate--db-remove-overlap-annotations (append annotations-before-merged + (list merged-annotation) + annotations-after-merged) + accum)) + (annotate--db-remove-overlap-annotations rest-annotations (push probe accum)))))) + +(defun annotate--db-merge-databases (db-1 db-2 &optional accum) + "Recursively merge database DB-1 and DB-2." + (cl-labels ((find-same-file-record (record annotations-db) + (let ((record-filename (annotate-filename-from-dump record))) + (cl-find-if (lambda (a) + (let ((scanned-record-filename (annotate-filename-from-dump a))) + (file-equal-p record-filename scanned-record-filename))) + annotations-db)))) + (if (null db-1) + (append accum db-2) + (let* ((first-record (cl-first db-1)) + (same-file-record (find-same-file-record first-record db-2))) + (if same-file-record + (let* ((filename (annotate-filename-from-dump first-record)) + (concatenated-annotations (append (annotate-annotations-from-dump first-record) + (annotate-annotations-from-dump same-file-record))) + (non-overlapped-annotations (annotate--db-remove-overlap-annotations concatenated-annotations)) + (concatenated-checksum (annotate-checksum-from-dump first-record)) + (concatenated-record (annotate-make-record filename + non-overlapped-annotations + concatenated-checksum)) + (rest-of-db-2 (cl-remove-if + (lambda (a) + (let ((record-filename (annotate-filename-from-dump a))) + (file-equal-p record-filename filename))) + db-2))) + (annotate--db-merge-databases (cl-rest db-1) + rest-of-db-2 + (push concatenated-record accum))) + (annotate--db-merge-databases (cl-rest db-1) + db-2 + (push first-record accum))))))) + +(defun annotate-import-annotations () + "Prompt user for an annotation database file and merge it into +their personal database." + (interactive) + (cl-flet ((deserialize-db (file) + (ignore-errors (annotate--deserialize-database-file file))) + (remove-non-existing-files (annotations) + (cl-remove-if-not (lambda (a) + (let ((filename (annotate-filename-from-dump a))) + (annotate-file-exists-p filename))) + annotations))) + (let* ((confirm-message (concat "Importing databases from untrusted source may cause severe " + "security issues, continue?")) + (import-confirmed-p (or (not annotate-database-confirm-import) + (y-or-n-p confirm-message)))) + (when import-confirmed-p + (let* ((imported-db-name (read-file-name "Choose the database to import: ")) + (imported-db (remove-non-existing-files (deserialize-db imported-db-name))) + (hosting-db (deserialize-db annotate-file)) + (merged-db (annotate--db-merge-databases hosting-db imported-db))) + (annotate-dump-annotation-data merged-db) + (annotate-switch-db t annotate-file) + (when annotate-use-messages + (message "Imported annotations from %s." imported-db-name))))))) + +;;; end of merging datatase + +(provide 'annotate) +;;; annotate.el ends here