From: Andreas Gerler Date: Sun, 11 Dec 2022 12:03:41 +0000 (+0100) Subject: add annotate X-Git-Url: http://git.bundesbrandschatzamt.de/?a=commitdiff_plain;h=1c1c0a3ace7051899f0014a769048f57a829546c;p=emacsconfig.git add annotate Signed-off-by: Andreas Gerler --- diff --git a/elpa/annotate-20220128.1118/annotate-autoloads.el b/elpa/annotate-20220128.1118/annotate-autoloads.el new file mode 100644 index 00000000..f1d35371 --- /dev/null +++ b/elpa/annotate-20220128.1118/annotate-autoloads.el @@ -0,0 +1,35 @@ +;;; annotate-autoloads.el --- automatically extracted autoloads +;; +;;; Code: + +(add-to-list 'load-path (directory-file-name + (or (file-name-directory #$) (car load-path)))) + + +;;;### (autoloads nil "annotate" "annotate.el" (0 0 0 0)) +;;; Generated autoloads from annotate.el + +(let ((loads (get 'annotate 'custom-loads))) (if (member '"annotate" loads) nil (put 'annotate 'custom-loads (cons '"annotate" loads)))) + +(autoload 'annotate-mode "annotate" "\ +Toggle Annotate mode. +See https://github.com/bastibe/annotate.el/ for documentation. + +If called interactively, enable Annotate mode if ARG is positive, +and disable it if ARG is zero or negative. If called from Lisp, +also enable the mode if ARG is omitted or nil, and toggle it if +ARG is `toggle'; disable the mode otherwise. + +\(fn &optional ARG)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "annotate" '("annotat"))) + +;;;*** + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; coding: utf-8 +;; End: +;;; annotate-autoloads.el ends here diff --git a/elpa/annotate-20220128.1118/annotate-pkg.el b/elpa/annotate-20220128.1118/annotate-pkg.el new file mode 100644 index 00000000..e7434621 --- /dev/null +++ b/elpa/annotate-20220128.1118/annotate-pkg.el @@ -0,0 +1,2 @@ +;;; Generated package description from annotate.el -*- no-byte-compile: t -*- +(define-package "annotate" "20220128.1118" "annotate files without changing them" 'nil :commit "0cfad246ee4c1297efa399e3d2c6ebb8bb46288b" :authors '(("Bastian Bechtold")) :maintainer '("Bastian Bechtold") :url "https://github.com/bastibe/annotate.el") diff --git a/elpa/annotate-20220128.1118/annotate.el b/elpa/annotate-20220128.1118/annotate.el new file mode 100644 index 00000000..8bdad789 --- /dev/null +++ b/elpa/annotate-20220128.1118/annotate.el @@ -0,0 +1,3341 @@ +;;; annotate.el --- annotate files without changing them +;; Copyright (C) 2015 Bastian Bechtold and contributors: +;; Naoya Yamashita (2018) +;; Universita' degli Studi di Palermo (2019) + +;; Author: Bastian Bechtold +;; Maintainer: Bastian Bechtold +;; URL: https://github.com/bastibe/annotate.el +;; Package-Version: 20220128.1118 +;; Package-Commit: 0cfad246ee4c1297efa399e3d2c6ebb8bb46288b +;; Created: 2015-06-10 +;; Version: 1.5.0 + +;; 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: 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 "1.5.0" + :group 'text) + +;;;###autoload +(define-minor-mode annotate-mode + "Toggle Annotate mode. +See https://github.com/bastibe/annotate.el/ for documentation." + :init-value nil + :lighter " Ann" + :keymap (make-sparse-keymap) + :group 'annotate + :after-hook (annotate-initialize-maybe)) + +(define-key annotate-mode-map (kbd "C-c C-a") 'annotate-annotate) + +(define-key annotate-mode-map (kbd "C-c C-d") 'annotate-delete-annotation) + +(define-key annotate-mode-map (kbd "C-c C-s") 'annotate-show-annotation-summary) + +(define-key annotate-mode-map (kbd "C-c ]") 'annotate-goto-next-annotation) + +(define-key annotate-mode-map (kbd "C-c [") 'annotate-goto-previous-annotation) + +(defcustom annotate-file (locate-user-emacs-file "annotations" ".annotations") + "File where annotations are stored." + :type 'file + :group 'annotate) + +(defface annotate-highlight + '((t (:underline "coral"))) + "Face for annotation highlights." + :group 'annotate) + +(defface annotate-highlight-secondary + '((t (:underline "khaki"))) + "Face for secondary annotation highlights." + :group 'annotate) + +(defface annotate-annotation + '((t (:background "coral" :foreground "black" :inherit default))) + "Face for annotations." + :group 'annotate) + +(defface annotate-annotation-secondary + '((t (:background "khaki" :foreground "black" :inherit default))) + "Face for secondary annotations." + :group 'annotate) + +(defface annotate-prefix + '((t (:inherit default))) + "Face for character used to pad annotation (fill space between +text lines and annotation text)." + :group 'annotate) + +(defcustom annotate-annotation-column 85 + "Where annotations appear." + :type 'number + :group 'annotate) + +(defcustom annotate-diff-export-options "" + "Other options for 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 + :group 'annotate) + +(defcustom annotate-use-messages t + "Whether status messages may appear in the minibuffer." + :type 'boolean + :group 'annotate) + +(defcustom annotate-integrate-marker " ANNOTATION: " + "Marker that is written before every integrated annotation." + :type 'string + :group 'annotate) + +(defcustom annotate-integrate-higlight ?~ + "Character used to underline an annotated text." + :type 'character + :group 'annotate) + +(defcustom annotate-fallback-comment "#" + "When variable `COMMENT-START' is nil use this string instead." + :type 'string + :group 'annotate) + +(defcustom annotate-blacklist-major-mode '() + "Prevent loading of annotate-mode When the visited file's +major mode is a member of this list (space separated entries)." + :type '(repeat symbol) + :group 'annotate) + +(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 + :group 'annotate) + +(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 + :group 'annotate) + +(defcustom annotate-annotation-confirm-deletion nil + "If non nil a prompt asking confirmation before deleting an +annotation file will be shown." + :type 'boolean + :group 'annotate) + +(defcustom annotate-database-confirm-import t + "If non nil a prompt asking confirmation before importing a +database file will be shown." + :type 'boolean + :group 'annotate) + +(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 + :group 'annotate) + +(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 + :group 'annotate) + +(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 + :group 'annotate) + +(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 + :group 'annotate) + +(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 + :group 'annotate) + +(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-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.") + +(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 + :group 'annotate) + +(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-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? " + "The string for the prompt to be shown when asking for annotation deletion confirm.") + +;;;; custom errors + +(define-error 'annotate-error "Annotation error") + +(define-error 'annotate-empty-annotation-text-error + "Empty annotation text" + '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 (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'." + (let ((annotate-allowed-p (with-current-buffer (current-buffer) + (not (cl-member major-mode annotate-blacklist-major-mode))))) + (cond + ((not annotate-allowed-p) + (annotate-shutdown) + (setq annotate-mode nil)) + (annotate-mode + (when (not (annotate-annotations-exist-p)) + (annotate-initialize))) + (t + (annotate-shutdown))))) + +(cl-defun annotate-buffer-checksum (&optional (object (current-buffer))) + "Calculate an hash for the argument `OBJECT'." + (secure-hash 'md5 object)) + +(cl-defmacro annotate-with-inhibit-modification-hooks (&rest body) + "Wrap `BODY' in a block with modification-hooks inhibited." + (let ((old-mode (gensym))) + `(let ((,old-mode inhibit-modification-hooks)) + (unwind-protect + (progn + (setf inhibit-modification-hooks t) + ,@body) + (setf inhibit-modification-hooks ,old-mode))))) + +(cl-defmacro annotate-with-restore-modified-bit (&rest body) + "Save the value of `BUFFER-MODIFIED-P' before `BODY' is executed +and restore the saved value just after the end of `BODY'." + (let ((modifiedp (gensym))) + `(let ((,modifiedp (buffer-modified-p))) + ,@body + (set-buffer-modified-p ,modifiedp)))) + +(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)." + (save-excursion + (end-of-line) + (point))) + +(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-force-newline-policy (annotation) + "Force annotate to place `ANNOTATION' on the line after the annotated text. + +See: `ANNOTATE-ANNOTATION-POSITION-POLICY'." + (overlay-put annotation 'force-newline-policy t)) + +(defun annotate-annotation-newline-policy-forced-p (annotation) + "Is `ANNOTATION' forced to place annotation on the line after the +annotated text? + +See: `ANNOTATE-ANNOTATION-POSITION-POLICY'." + (overlay-get annotation 'force-newline-policy)) + +(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)." + (annotate-with-inhibit-modification-hooks + (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) + (font-lock-flush)))))))))) + +(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 annotate-initialize () + "Load annotations and set up save and display hooks." + (annotate-load-annotations) + (add-hook 'after-save-hook 'annotate-save-annotations t t) + (add-hook 'window-configuration-change-hook 'font-lock-flush 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) + (remove-hook 'after-save-hook 'annotate-save-annotations t) + (remove-hook 'window-configuration-change-hook 'font-lock-flush 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) + (overlay-get overlay 'annotation))) + +(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 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-annotate () + "Create, modify, or delete annotation." + (interactive) + (cl-labels ((create-new-annotation () + ;; create a new annotation in the region returned by `annotate-bound' + (cl-destructuring-bind (start end) + (annotate-bounds) + (let ((annotation-text (read-from-minibuffer annotate-annotation-prompt))) + (condition-case error-message + (annotate-create-annotation start end annotation-text nil) + (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' end ending on + ;; `region-stop' will be cleared of all annotations. + (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-beg region-stop &optional 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 staring from `region-beg' end ending on + ;; `region-stop' will be cleared of all annotations. + (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) + (let ((start-pos-last-annotation (overlay-start starting-chain-at-end))) + (cut-left start-pos-last-annotation 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-beg 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)))))))))))) + (set-buffer-modified-p t)))) + +(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-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 + (when as-new-buffer + (erase-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 (overlay-get overlay + 'annotation))) + (ov-length (- relative-end relative-start)) + (underline (make-string (1- ov-length) + annotate-integrate-higlight))) + (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: + +--- /home/bastibe/Projects/annotate.el/annotate.el 2015-06-19 15:13:36.718796738 +0200 ++++ /home/bastibe/Projects/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.\" + :group 'annotate) + +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)) + (next-word (cl-first nonjoined-words)) + (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)) + "Returns 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")) + "Returns `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 (overlay-get annotation-overlay 'annotation))) + (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--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) + (annotation-counter 1)) + ;; 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 actual position of the annotation (newline + ;; or right margin) is indicated by the value of the + ;; variable: `annotate-annotation-position-policy'. + (dolist (ov overlays) + (let* ((face (cond + ((annotate-previous-annotation ov) + (let* ((previous (annotate-previous-annotation ov)) + (prev-face (overlay-get previous + 'annotation-face))) + (if (eq prev-face + 'annotate-annotation) + 'annotate-annotation-secondary + 'annotate-annotation))) + ((not (annotate-chain-first-p ov)) + (let ((first-in-chain (annotate-chain-first ov))) + (overlay-get first-in-chain + 'annotation-face))) + (t + 'annotate-annotation))) + (face-highlight (if (eq face + 'annotate-annotation) + 'annotate-highlight + 'annotate-highlight-secondary)) + (annotation-long-p (> (string-width (overlay-get ov 'annotation)) + annotate-annotation-max-size-not-place-new-line)) + (position-new-line-p (cl-case annotate-annotation-position-policy + (:new-line + t) + (:by-length + (or (annotate-annotation-newline-policy-forced-p ov) + annotation-long-p)) + (otherwise + nil))) + (multiline-annotation (annotate-wrap-annotation-in-box ov + bol + eol + position-new-line-p)) + (annotation-stopper (if position-new-line-p + (if (= annotation-counter + (length overlays)) + "\n" + "") + "\n"))) + (cl-incf annotation-counter) + (overlay-put ov 'face face-highlight) + (overlay-put ov 'annotation-face face) + (when (not (annotate-chain-first-p ov)) + (let ((first-in-chain (annotate-chain-first ov))) + (overlay-put ov + 'face + (overlay-get first-in-chain 'face)))) + (when (and (not annotate-use-echo-area) + (annotate-chain-last-p ov)) + (when position-new-line-p + (setf prefix-first " \n")) + (dolist (l multiline-annotation) + (setq annotation-text + (concat annotation-text + prefix-first + (propertize l 'face face) + annotation-stopper)) + ;; white space before for all but the first annotation line + (if position-new-line-p + (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 (> (buffer-size) 0) + (not (buffer-narrowed-p))) + (annotate-with-inhibit-modification-hooks + (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 + (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) + "Returns the annotations overlays that are enclosed in the range +defined by `FROM-POSITION' and `TO-POSITION'." + (let ((annotations ())) + (cl-loop for i + from (max 0 (1- from-position)) + to to-position + do + (let ((annotation (annotate-next-annotation-starts i))) + (annotate-ensure-annotation (annotation) + (let ((chain-end (overlay-end (annotate-chain-last annotation))) + (chain-start (overlay-start (annotate-chain-first annotation)))) + (when (and (>= chain-start from-position) + (<= chain-end to-position)) + (cl-pushnew annotation annotations)))))) + (reverse annotations))) + +(defun annotate-annotations-chain-in-range (from-position to-position) + "Returns 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 () + "Returns 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)) + +(defun annotate-actual-file-name () + "Get the actual file name of the current buffer." + (substring-no-properties (or (annotate-info-actual-filename) + (buffer-file-name) + ""))) + +(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-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) + "Returns a list of two numbers representing the left and right +limit respectively of the portion of the buffer where this +annotation is applied. +Note that this function returns the character interval +yyyyyyyy ggg + ^^^^^^^ ← Annotation interval i the database (extends for one more than the last character) + |----| ← The interval that this function returns. + +In other terms the interval i 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-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)))) + (if (assoc-string filename all-annotations) + (setcdr (assoc-string filename all-annotations) + (list file-annotations + (annotate-buffer-checksum))) + (setq all-annotations + (push (list 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.")))) + +(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)))) + (modified-p (buffer-modified-p))) + ;; 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 "No annotations 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))))) + (set-buffer-modified-p modified-p) + (font-lock-flush) + (when annotate-use-messages + (message "Annotations loaded.")))) + +(defun annotate-load-annotations () + "Load all annotations from disk and redraw the buffer to render the annotations. + +The format of the database is: + +\(list record-1 record-2 ... record-n) + +Each record is: + +\(list 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: + +\(list annotation-1 annotation-2 ... annotation-n) or nil + +finally annotation is: + +\(list start end annotation-string annotated-text) + +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 starting from 'start' an ending with 'end' (as above) + +example: + +'(\"/foo/bar\" ((0 9 \"note\" \"annotated\")) 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)) + (modified-p (buffer-modified-p))) + (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 "No annotations 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))) + (annotate-create-annotation start + end + annotation-string + annotated-text)))))) + (set-buffer-modified-p modified-p) + (font-lock-flush) + (when annotate-use-messages + (message "Annotations 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)) + (expand-p (not (eq (ignore-errors (annotate-guess-file-format short-filename)) + :info))) + (actual-filename (if expand-p + (expand-file-name short-filename) + short-filename))) + (annotate-make-record actual-filename + annotations + file-checksum))) + +(defun annotate--deserialize-database-file (file) +"Returns 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? [y/N] ") + (delete-confirmed-p (or (not annotate-database-confirm-deletion) + (string= (read-from-minibuffer (format confirm-message + annotate-file)) + "y")))) + (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))) + (modifiedp (buffer-modified-p))) + ;; 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) + (setf modifiedp t) + (set-buffer-modified-p modifiedp)))) + +(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 `point'." + (annotate-find-chain (annotate-annotation-at pos))) + +(defun annotate-create-annotation (start end annotation-text annotated-text) + "Create a new annotation for selected region. + +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'." + (cl-labels ((create-annotation (start end annotation-text) + (save-excursion + (let ((chain-pos 0) + (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))) + (overlay-put highlight 'face 'annotate-highlight) + (overlay-put highlight 'annotation annotation-text) + (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)))) + (cl-remove-if #'null all-faces))) + (setf force-newline-p + (cl-find-if (lambda (a) (/= a default-face-height)) + all-faces-height)) + (when force-newline-p + (annotate-annotation-force-newline-policy annotation)) + annotation)))) + (if (annotate-string-empty-p annotation-text) + (signal 'annotate-empty-annotation-text-error t) + (progn + (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 `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) + (annotate-with-restore-modified-bit + (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))))) + +(defun annotate-change-annotation (pos) + "Change annotation at point. If empty, delete annotation." + (let* ((highlight (annotate-annotation-at pos)) + (annotation-text (read-from-minibuffer annotate-annotation-prompt + (overlay-get highlight 'annotation)))) + (cl-labels ((change (annotation) + (let ((chain (annotate-find-chain annotation))) + (dolist (single-element chain) + (annotate-overlay-maybe-set-help-echo single-element annotation-text) + (overlay-put single-element 'annotation 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) + "Returns 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) + "Returns 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) + "Returns 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) + "Returns the previous annotation that ends before `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) + "Returns 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 () + "Returns 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 () + "Returns a list of all annotations in the current buffer." + (cl-remove-if-not #'annotationp (overlays-in 0 (buffer-size)))) + +(defun annotate-describe-annotations () + "Returns a list, suitable for database dump, of all annotations in the current buffer." + (let ((all-annotations (cl-remove-if-not #'annotationp (overlays-in 0 (buffer-size)))) + (chain-visited ())) + (cl-remove-if #'null + (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))) + (when (not (cl-find-if (lambda (a) + (eq (cl-first chain) + (cl-first a))) + chain-visited)) + (push chain chain-visited) + (list from + to + (overlay-get annotation 'annotation) + (buffer-substring-no-properties from to))))) + all-annotations)))) + +(defun annotate-info-root-dir-p (filename) + "Is the name of this file equals to the info root node?" + (string= filename + annotate-info-root-name)) + +(defun annotate-guess-file-format (filename) + "Try to guess the file format. +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 (or (annotate-info-root-dir-p filename) + (and has-separator-p + has-node-p) + (and has-separator-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-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 + (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)) + (begin-of-button (button-get button 'begin-of-button)) + (end-of-button (button-get button 'end-of-button)) + (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 + (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-annotations)) + (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 + ;; where + ;; previous-token is the value of the token just matched in rule + ;; NOTE OPERATOR NOTE + ;; filter-fn see the docstring + ;; matchp non nil if (funcall filter-fn previous-token) is not nil + (operator (previous-token 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 escaped 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 regex 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 + (cl-remove-if 'null 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 (cl-remove-if 'null (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 () + "Returns 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) + 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? [y/N] ") + (load-file-confirmed (if force-load + t + (string= (read-from-minibuffer (format confirm-message + new-db)) + "y")))) + (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 + (let ((buffer-was-modified-p (buffer-modified-p annotated-buffer))) + (annotate-with-inhibit-modification-hooks + (annotate-mode -1) + (annotate-mode 1) + (when (not buffer-was-modified-p) + (set-buffer-modified-p nil))))))) + (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) +"Returns 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' using `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 (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 int +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? [y/N] ")) + (import-confirmed-p (or (not annotate-database-confirm-import) + (string= (read-from-minibuffer (format confirm-message + annotate-file)) + "y")))) + (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