branch: elpa/annotate
commit c42686bab57c31bf0da0595af506b190f0584e86
Author: cage <cage-invalid@invalid>
Commit: cage <cage-invalid@invalid>
- allow overwriting (even partial) of annotations.
That is, user can place an annotation on top of an already existing
one. The new will delete overlapped portion of the old annotation.
This feature should not allow to break an annotation,
though. Annotations can not overlaps.
- added a new customizable variable: 'annotate-warn-if-hash-mismatch'
when nil prevent printing of warning when annotation database's'
hash and file has do not match.
- fixed bug in alternating coloring of annotation and underlined text;
- updated README;
- fixed some typos.
---
README.org | 15 ++++
annotate.el | 277 ++++++++++++++++++++++++++++++++++++++++++++++++++++--------
2 files changed, 255 insertions(+), 37 deletions(-)
diff --git a/README.org b/README.org
index 615ede331d..bd4bad3de7 100644
--- a/README.org
+++ b/README.org
@@ -37,10 +37,22 @@ the command ~annotate-switch-db~. This command will
take care to
refresh/redraw all annotations in the buffers that uses
~annotate-mode~.
+The database holds the hash of each annoatated file so it can print a
+warning if the file has been modified outside Emacs (for example).
+
+Warning can be suppressed setting the variable
+~annotate-warn-if-hash-mismatch~ to nil.
+
Please note that switching database, in this context, means rebinding
the aforementioned variable (~annotate-file~). This means than no
more than a single database can be active for each Emacs session.
+To use multiple database in the same Emacs session ~annotate-file~ should be
made
+[[https://www.gnu.org/software/emacs/manual/html_node/elisp/Buffer_002dLocal-Variables.html][buffer-local]],
+see:
+[[https://github.com/bastibe/annotate.el/issues/68][this thread]] and, in
particular
+[[https://github.com/bastibe/annotate.el/issues/68#issuecomment-728218022][this
message]].
+
Users of
[[https://github.com/emacscollective/no-littering][no-littering]]
can take advantage of its packages generated files management.
@@ -48,6 +60,9 @@ can take advantage of its packages generated files management.
**** related customizable variable
- ~annotate-file~
+**** related customizable variable
+ - ~annotate-warn-if-hash-mismatch~
+
** keybindings
*** ~C-c C-a~ (function annotate-annotate)
diff --git a/annotate.el b/annotate.el
index 54b2db9972..72ec632975 100644
--- a/annotate.el
+++ b/annotate.el
@@ -184,6 +184,18 @@ 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)
+
(defconst annotate-prop-chain-position
'position)
@@ -514,6 +526,19 @@ that belong to some annotated text?"
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)
@@ -524,21 +549,72 @@ that belong to some annotated text?"
(condition-case error-message
(annotate-create-annotation start end annotation-text
nil)
(annotate-empty-annotation-text-error
- (user-error "Annotation text is empty.")))))))
+ (user-error "Annotation text is empty."))))))
+ (cut-right (region-beg region-stop &optional delete-enclosed)
+ (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)
+ (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)))))
(let ((annotation (annotate-annotation-at (point))))
(cond
((use-region-p)
- (let* ((region-beg (region-beginning))
- (region-stop (region-end))
- (annotations (cl-remove-if-not #'annotationp
- (overlays-in region-beg
- region-stop))))
+ (let* ((region-beg (region-beginning))
+ (region-stop (region-end))
+ (enclosed-chains (annotate-annotations-chain-in-range
region-beg region-stop)))
(cond
- (annotations
- (signal 'annotate-annotate-region-overlaps annotations))
- ((or (annotate--position-on-annotated-text-p region-beg)
- (annotate--position-on-annotated-text-p region-stop))
- (signal 'annotate-annotate-region-overlaps nil))
+ ((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
@@ -904,7 +980,7 @@ to 'maximum-width'."
grouped))))
(cl-defun annotate-safe-subseq (seq from to &optional (value-if-limits-invalid
seq))
- "This return 'value-if-limits-invalid' sequence if 'from' or 'to' are
invalids"
+ "Returns 'value-if-limits-invalid' sequence if 'from' or 'to' are invalids"
(cond
((< to from)
value-if-limits-invalid)
@@ -984,15 +1060,22 @@ to 'maximum-width'."
;; 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)))
- ((= (cl-rem annotation-counter 2) 0)
- 'annotate-annotation)
(t
- 'annotate-annotation-secondary)))
- (face-highlight (if (= (cl-rem annotation-counter 2) 0)
+ 'annotate-annotation)))
+ (face-highlight (if (eq face
+ 'annotate-annotation)
'annotate-highlight
'annotate-highlight-secondary))
(annotation-long-p (> (string-width (overlay-get ov
'annotation))
@@ -1020,12 +1103,12 @@ to 'maximum-width'."
"\n")))
(cl-incf annotation-counter)
(overlay-put ov 'face face-highlight)
- (if (annotate-chain-first-p ov)
- (overlay-put ov 'annotation-face face)
- (let ((first-in-chain (annotate-chain-first ov)))
- (overlay-put ov
- 'face
- (overlay-get first-in-chain 'face))))
+ (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
@@ -1069,6 +1152,33 @@ to 'maximum-width'."
(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
@@ -1080,7 +1190,7 @@ an overlay and it's annotation."
'(annotate--remove-annotation-property)))
(defun annotate-context-before (pos)
- "Context lines before POS. Return nil if we reach a line before
+ "Context lines before POS. Returns nil if we reach a line before
first line of the buffer"
(save-excursion
(goto-char pos)
@@ -1314,7 +1424,8 @@ example:
(modified-p (buffer-modified-p)))
(if (old-format-p annotation-dump)
(annotate-load-annotation-old-format)
- (when (and (not (old-format-p annotation-dump))
+ (when (and annotate-warn-if-hash-mismatch
+ (not (old-format-p annotation-dump))
old-checksum
new-checksum
(not (string= old-checksum new-checksum)))
@@ -1364,7 +1475,7 @@ annotation."
(annotate-dump-annotation-data db)))
(defun annotate-load-annotation-data (&optional ignore-errors)
- "Read and return saved annotations."
+ "Read and returns saved annotations."
(cl-flet ((%load-annotation-data ()
(let ((annotations-file annotate-file))
(with-temp-buffer
@@ -1575,6 +1686,12 @@ of a chain of annotations"
(annotate-ensure-annotation (annotation)
(annotate-chain-last annotation))))
+(defun annotate-chain-at (pos)
+ "Find last the chain of annotations that overlap point `pos'"
+ (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"
@@ -1779,20 +1896,96 @@ 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
+ (let ((chain (annotate-find-chain annotation)))
+ (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.
+
+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 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-fontify-buffer)))))
+ (t
+ (move-overlay last-annotation last-annotation-starting-pos
new-ending-pos))))))
+
(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 ((delete (annotation)
- (let ((chain (annotate-find-chain annotation)))
- (annotate-with-restore-modified-bit
- (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)))))
+ (annotate-with-restore-modified-bit
+ (annotate--delete-annotation-chain annotation)))
(change (annotation)
(let ((chain (annotate-find-chain annotation)))
(dolist (single-element chain)
@@ -1847,6 +2040,11 @@ NOTE this assumes that annotations never overlaps"
(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.
@@ -1864,8 +2062,13 @@ NOTE this assumes that annotations never overlaps"
(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 ()
- "Return non nil if a symbol is at char immediately following
+ "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."
@@ -1926,11 +2129,11 @@ content `annotation' and annotated text
`annotated-text'."
(list beginning ending annotation annotated-text))
(defun annotate-all-annotations ()
- "Return a list of all annotations in the current buffer."
+ "Returns a list of all annotations in the current buffer."
(cl-remove-if-not #'annotationp (overlays-in 0 (buffer-size))))
(defun annotate-describe-annotations ()
- "Return a list, suitable for database dump, of all annotations in the
current buffer."
+ "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
@@ -2539,7 +2742,7 @@ OR := 'or'
NOT := 'not'
DELIMITER := \" ; ASCII 34 (dec) 22 (hex)
-Note: this function return the annotation part of the record, see
+Note: this function returns the annotation part of the record, see
`annotate-load-annotations'.
"
